From 079a14606e212244cca692716b0866542ae7968c Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sun, 3 Nov 2024 13:36:57 +0100 Subject: [PATCH] Update cpmfiles --- 8080/CPM/cpmfiles/ass8080.fb | 1 + 8080/CPM/cpmfiles/block.fth | 679 +++++++++++++++++++++++++++++ 8080/CPM/cpmfiles/coreacpt.fth | 35 ++ 8080/CPM/cpmfiles/coreext.fth | 769 +++++++++++++++++++++++++++++++++ 8080/CPM/cpmfiles/coreplus.fth | 306 +++++++++++++ 8080/CPM/cpmfiles/doubltst.fth | 438 +++++++++++++++++++ 8080/CPM/cpmfiles/errorrep.fth | 88 ++++ 8080/CPM/cpmfiles/incltest.fth | 10 + 8080/CPM/cpmfiles/include.fb | 2 +- 8080/CPM/cpmfiles/log2file.fth | 95 ++++ 8080/CPM/cpmfiles/logapp.fth | 78 ++++ 8080/CPM/cpmfiles/logprep.fth | 14 + 8080/CPM/cpmfiles/logtest.fth | 38 ++ 8080/CPM/cpmfiles/savesys.fb | 1 + 8080/CPM/cpmfiles/tc-base.com | Bin 0 -> 19456 bytes 8080/CPM/cpmfiles/test-blk.fth | 26 ++ 8080/CPM/cpmfiles/test-std.fth | 29 ++ 8080/CPM/cpmfiles/testprep.fth | 38 ++ 8080/CPM/cpmfiles/util.fth | 143 ++++++ 8080/CPM/cpmfiles/v4th.com | Bin 13440 -> 13440 bytes 8080/CPM/cpmfiles/vf-core.fth | 3 +- 8080/CPM/cpmfiles/vf-file.fth | 171 ++++++++ 8080/CPM/cpmfiles/xinout.fb | 1 + 23 files changed, 2963 insertions(+), 2 deletions(-) create mode 100644 8080/CPM/cpmfiles/ass8080.fb create mode 100644 8080/CPM/cpmfiles/block.fth create mode 100644 8080/CPM/cpmfiles/coreacpt.fth create mode 100644 8080/CPM/cpmfiles/coreext.fth create mode 100644 8080/CPM/cpmfiles/coreplus.fth create mode 100644 8080/CPM/cpmfiles/doubltst.fth create mode 100644 8080/CPM/cpmfiles/errorrep.fth create mode 100644 8080/CPM/cpmfiles/incltest.fth create mode 100644 8080/CPM/cpmfiles/log2file.fth create mode 100644 8080/CPM/cpmfiles/logapp.fth create mode 100644 8080/CPM/cpmfiles/logprep.fth create mode 100644 8080/CPM/cpmfiles/logtest.fth create mode 100644 8080/CPM/cpmfiles/savesys.fb create mode 100644 8080/CPM/cpmfiles/tc-base.com create mode 100644 8080/CPM/cpmfiles/test-blk.fth create mode 100644 8080/CPM/cpmfiles/test-std.fth create mode 100644 8080/CPM/cpmfiles/testprep.fth create mode 100644 8080/CPM/cpmfiles/util.fth create mode 100644 8080/CPM/cpmfiles/vf-file.fth create mode 100644 8080/CPM/cpmfiles/xinout.fb diff --git a/8080/CPM/cpmfiles/ass8080.fb b/8080/CPM/cpmfiles/ass8080.fb new file mode 100644 index 0000000..ce1c1b4 --- /dev/null +++ b/8080/CPM/cpmfiles/ass8080.fb @@ -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/CPM/cpmfiles/block.fth b/8080/CPM/cpmfiles/block.fth new file mode 100644 index 0000000..cb1b450 --- /dev/null +++ b/8080/CPM/cpmfiles/block.fth @@ -0,0 +1,679 @@ +\ To test the ANS Forth Block word set and extension words + +\ This program was written by Steve Palmer in 2015, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct + +\ ------------------------------------------------------------------------------ +\ Version 0.1 23 October 2015 First Version +\ Version 0.2 15 November 2015 Updated after feedback from Gerry Jackson + +\ ------------------------------------------------------------------------------ +\ The tests are based on John Hayes test program for the core word set +\ +\ Words tested in this file are: +\ BLK BLOCK BUFFER EVALUATE FLUSH LOAD SAVE-BUFFERS UPDATE +\ EMPTY-BUFFERS LIST SCR THRU REFILL SAVE-INPUT RESTORE-INPUT \ +\ +\ ------------------------------------------------------------------------------ +\ Assumptions and dependencies: +\ - tester.fr or ttester.fs has been loaded prior to this file +\ - errorreport.fth has been loaded prior to this file +\ - utilities.fth has been loaded prioir to this file +\ ------------------------------------------------------------------------------ + +use empty.fb + +TESTING Block word set + +DECIMAL + +\ Define these constants from the system documentation provided. +\ WARNING: The contents of the test blocks will be destroyed by this test. +\ The blocks tested will be in the range +\ FIRST-TEST-BLOCK <= u < LIMIT-TEST-BLOCK +\ The tests need at least 2 test blocks in the range to complete. +20 CONSTANT FIRST-TEST-BLOCK +30 CONSTANT LIMIT-TEST-BLOCK \ one beyond the last + +FIRST-TEST-BLOCK LIMIT-TEST-BLOCK U< 0= [?IF] +\? .( Error: Test Block range not identified ) CR ABORT +[?THEN] + +LIMIT-TEST-BLOCK FIRST-TEST-BLOCK - CONSTANT TEST-BLOCK-COUNT +TEST-BLOCK-COUNT 2 U< [?IF] +\? .( Error: At least 2 Test Blocks are required to run the tests ) CR ABORT +[?THEN] + +\ ------------------------------------------------------------------------------ +TESTING Random Number Utilities + +\ The block tests make extensive use of random numbers to select blocks to test +\ and to set the contents of the block. It also makes use of a Hash code to +\ ensure the integrity of the blocks against unexpected changes. + +\ == Memory Walk tools == + +: @++ ( a-addr -- a-addr+4 a-addr@ ) + DUP CELL+ SWAP @ ; + +: !++ ( x a-addr -- a-addr+4 ) + TUCK ! CELL+ ; + +: C@++ ( c-addr -- c-addr;char+ c-addr@ ) + DUP CHAR+ SWAP C@ ; + +: C!++ ( char c-addr -- c-addr+1 ) + TUCK ! CHAR+ ; + +\ == Random Numbers == +\ Based on "Xorshift" PRNG wikipedia page +\ reporting on results by George Marsaglia +\ https://en.wikipedia.org/wiki/Xorshift +\ Note: THIS IS NOT CRYPTOGRAPHIC QUALITY + +: PRNG + CREATE ( "name" -- ) + 4 CELLS ALLOT + DOES> ( -- prng ) +; + +: PRNG-ERROR-CODE ( prng -- errcode | 0 ) + 0 4 0 DO \ prng acc + >R @++ R> OR \ prng acc' + LOOP \ prng xORyORzORw + NIP 0= ; \ xORyORzORw=0 + +: PRNG-COPY ( src-prng dst-prng -- ) + 4 CELLS MOVE ; + +: PRNG-SET-SEED ( prng w z y x -- ) + 4 PICK \ prng w z y x prng + 4 0 DO !++ LOOP DROP \ prng + DUP PRNG-ERROR-CODE IF \ prng + 1 OVER +! \ prng + THEN \ prng + DROP ; \ + +BITS/CELL 64 = [?IF] +\? : PRNG-RND ( prng -- rnd ) +\? DUP @ +\? DUP 21 LSHIFT XOR +\? DUP 35 RSHIFT XOR +\? DUP 4 LSHIFT XOR +\? TUCK SWAP ! ; +[?THEN] + +BITS/CELL 32 = [?IF] +\? : PRNG-RND ( prng -- rnd ) +\? DUP @ \ prng x +\? DUP 11 LSHIFT XOR \ prng t=x^(x<<11) +\? DUP 8 RSHIFT XOR \ prng t'=t^(t>>8) +\? OVER DUP CELL+ SWAP 3 CELLS MOVE \ prng t' +\? OVER 3 CELLS + @ \ prng t' w +\? DUP 19 RSHIFT XOR \ prng t' w'=w^(w>>19) +\? XOR \ prng rnd=w'^t' +\? TUCK SWAP 3 CELLS + ! ; \ rnd +[?THEN] + +BITS/CELL 16 = [?IF] +\? .( === NOT TESTED === ) +\? \ From http://b2d-f9r.blogspot.co.uk/2010/08/16-bit-xorshift-rng-now-with-more.html +\? : PRNG-RND ( prng -- rnd ) +\? DUP @ \ prng x +\? DUP 5 LSHIFT XOR \ prng t=x^(x<<5) +\? DUP 3 RSHIFT XOR \ prng t'=t^(t>>3) +\? OVER DUP CELL+ @ TUCK SWAP ! \ prng t' y +\? DUP 1 RSHIFT XOR \ prng t' y'=y^(y>>1) +\? XOR \ prng rnd=y'^t' +\? TUCK SWAP CELL+ ! ; \ rnd +[?THEN] + +[?DEF] PRNG-RND +\? .( You need to add a Psuedo Random Number Generator for your cell size: ) +\? BITS/CELL U. CR +\? ABORT +[?THEN] + +: PRNG-RANDOM ( lower upper prng -- rnd ) + >R OVER - R> PRNG-RND UM* NIP + ; +\ PostCondition: T{ lower upper 2DUP 2>R prng PRNG-RANDOM 2R> WITHIN -> TRUE }T + +PRNG BLOCK-PRNG +\ Generated by Random.org +BLOCK-PRNG -1865266521 188896058 -2021545234 -1456609962 PRNG-SET-SEED +: BLOCK-RND ( -- rnd ) BLOCK-PRNG PRNG-RND ; +: BLOCK-RANDOM ( lower upper -- rnd ) BLOCK-PRNG PRNG-RANDOM ; + +: RND-TEST-BLOCK ( -- blk ) + FIRST-TEST-BLOCK LIMIT-TEST-BLOCK BLOCK-RANDOM ; +\ PostCondition: T{ RND-TEST-BLOCK FIRST-TEST-BLOCK LIMIT-TEST-BLOCK WITHIN -> TRUE }T + +\ Two distinct random test blocks +: 2RND-TEST-BLOCKS ( -- blk1 blk2 ) + RND-TEST-BLOCK BEGIN \ blk1 + RND-TEST-BLOCK \ blk1 blk2 + 2DUP = \ blk1 blk2 blk1==blk2 + WHILE \ blk1 blk1 + DROP \ blk1 + REPEAT ; \ blk1 blk2 +\ PostCondition: T{ 2RND-TEST-BLOCKS = -> FALSE }T + +\ first random test block in a sequence of length u +: RND-TEST-BLOCK-SEQ ( u -- blks ) + FIRST-TEST-BLOCK LIMIT-TEST-BLOCK ROT 1- - BLOCK-RANDOM ; + +\ I'm not sure if this algorithm is correct if " 1 CHARS 1 <> ". +: ELF-HASH-ACCUMULATE ( hash c-addr u -- hash ) + >R SWAP R> 0 DO \ c-addr h + 4 LSHIFT \ c-addr h<<=4 + SWAP C@++ ROT + \ c-addr' h+=*s + DUP [ HEX ] F0000000 [ DECIMAL ] AND \ c-addr' h high=h&0xF0000000 + DUP IF \ c-addr' h high + DUP >R 24 RSHIFT XOR R> \ c-addr' h^=high>>24 high + THEN \ c-addr' h high + INVERT AND \ c-addr' h&=~high + LOOP NIP ; + +: ELF-HASH ( c-addr u -- hash ) + 0 ROT ROT ELF-HASH-ACCUMULATE ; + +\ ------------------------------------------------------------------------------ +TESTING BLOCK ( read-only mode ) + +\ BLOCK signature +T{ RND-TEST-BLOCK BLOCK DUP ALIGNED = -> TRUE }T + +\ BLOCK accepts all blocks in the test range +: BLOCK-ALL ( blk2 blk1 -- ) + DO + I BLOCK DROP + LOOP ; +T{ LIMIT-TEST-BLOCK FIRST-TEST-BLOCK BLOCK-ALL -> }T + +\ BLOCK twice on same block returns the same value +T{ RND-TEST-BLOCK DUP BLOCK SWAP BLOCK = -> TRUE }T + +\ BLOCK twice on distinct block numbers +\ may or may not return the same value! +\ Nothing to test + +\ ------------------------------------------------------------------------------ +TESTING BUFFER ( read-only mode ) + +\ Although it is not in the spirit of the specification, +\ a compliant definition of BUFFER would be +\ : BUFFER BLOCK ; +\ So we can only repeat the tests for BLOCK ... + +\ BUFFER signature +T{ RND-TEST-BLOCK BUFFER DUP ALIGNED = -> TRUE }T + +\ BUFFER accepts all blocks in the test range +: BUFFER-ALL ( blk2 blk1 -- ) + DO + I BUFFER DROP + LOOP ; +T{ LIMIT-TEST-BLOCK FIRST-TEST-BLOCK BUFFER-ALL -> }T + +\ BUFFER twice on the same block returns the same value +T{ RND-TEST-BLOCK DUP BUFFER SWAP BUFFER = -> TRUE }T + +\ BUFFER twice on distinct block numbers +\ may or may not return the same value! +\ Nothing to test + +\ Combinations with BUFFER +T{ RND-TEST-BLOCK DUP BLOCK SWAP BUFFER = -> TRUE }T +T{ RND-TEST-BLOCK DUP BUFFER SWAP BLOCK = -> TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING Read and Write access with UPDATE and FLUSH + +\ Ideally, we'd like to be able to test the persistence across power cycles +\ of the writes, but we can't do that in a simple test. +\ The tests below could be fooled by a large buffers store and a tricky FLUSH +\ but what else are you going to do? + +\ Signatures +T{ RND-TEST-BLOCK BLOCK DROP UPDATE -> }T +T{ FLUSH -> }T + +: BLANK-BUFFER ( blk -- blk-addr ) + BUFFER DUP 1024 BL FILL ; + +\ Test R/W of a Simple Blank Random Block +T{ RND-TEST-BLOCK \ blk + DUP BLANK-BUFFER \ blk blk-addr1 + 1024 ELF-HASH \ blk hash + UPDATE FLUSH \ blk hash + SWAP BLOCK \ hash blk-addr2 + 1024 ELF-HASH = -> TRUE }T + +\ Boundary Test: Modify first character +T{ RND-TEST-BLOCK \ blk + DUP BLANK-BUFFER \ blk blk-addr1 + CHAR \ OVER C! \ blk blk-addr1 + 1024 ELF-HASH \ blk hash + UPDATE FLUSH \ blk hash + SWAP BLOCK \ hash blk-addr2 + 1024 ELF-HASH = -> TRUE }T + +\ Boundary Test: Modify last character +T{ RND-TEST-BLOCK \ blk + DUP BLANK-BUFFER \ blk blk-addr1 + CHAR \ OVER 1023 CHARS + C! \ blk blk-addr1 + 1024 ELF-HASH \ blk hash + UPDATE FLUSH \ blk hash + SWAP BLOCK \ hash blk-addr2 + 1024 ELF-HASH = -> TRUE }T + +\ Boundary Test: First and Last (and all other) blocks in the test range +1024 8 * BITS/CELL / CONSTANT CELLS/BLOCK + +: PREPARE-RND-BLOCK ( hash blk -- hash' ) + BUFFER DUP \ hash blk-addr blk-addr + CELLS/BLOCK 0 DO \ hash blk-addr blk-addr[i] + BLOCK-RND OVER ! CELL+ \ hash blk-addr blk-addr[i+1] + LOOP DROP \ hash blk-addr + 1024 ELF-HASH-ACCUMULATE ; \ hash' + +: WRITE-RND-BLOCKS-WITH-HASH ( blk2 blk1 -- hash ) + 0 ROT ROT DO \ hash + I PREPARE-RND-BLOCK UPDATE \ hash' + LOOP ; \ hash' + +: READ-BLOCKS-AND-HASH ( blk2 blk1 -- hash ) + 0 ROT ROT DO \ hash(i) + I BLOCK 1024 ELF-HASH-ACCUMULATE \ hash(i+1) + LOOP ; \ hash + +T{ LIMIT-TEST-BLOCK FIRST-TEST-BLOCK WRITE-RND-BLOCKS-WITH-HASH FLUSH + LIMIT-TEST-BLOCK FIRST-TEST-BLOCK READ-BLOCKS-AND-HASH = -> TRUE }T + +: TUF1 ( xt blk -- hash ) + DUP BLANK-BUFFER \ xt blk blk-addr1 + 1024 ELF-HASH \ xt blk hash + ROT EXECUTE \ blk hash + SWAP BLOCK \ hash blk-addr2 + 1024 ELF-HASH = ; \ TRUE + +\ Double UPDATE make no difference +: TUF1-1 ( -- ) UPDATE UPDATE FLUSH ; +T{ ' TUF1-1 RND-TEST-BLOCK TUF1 -> TRUE }T + +\ Double FLUSH make no difference +: TUF1-2 ( -- ) UPDATE FLUSH FLUSH ; +T{ ' TUF1-2 RND-TEST-BLOCK TUF1 -> TRUE }T + +\ FLUSH only saves UPDATEd buffers +T{ RND-TEST-BLOCK \ blk + 0 OVER PREPARE-RND-BLOCK \ blk hash + UPDATE FLUSH \ blk hash + OVER 0 SWAP PREPARE-RND-BLOCK DROP \ blk hash + FLUSH ( with no preliminary UPDATE) \ blk hash + SWAP BLOCK 1024 ELF-HASH = -> TRUE }T + +\ UPDATE only marks the current block buffer +\ This test needs at least 2 distinct buffers, though this is not a +\ requirement of the language specification. If 2 distinct buffers +\ are not returned, then the tests quits with a trivial Pass +: TUF2 ( xt blk1 blk2 -- hash1'' hash2'' hash1' hash2' hash1 hash2 ) + OVER BUFFER OVER BUFFER = IF \ test needs 2 distinct buffers + 2DROP DROP 0 0 0 0 0 0 \ Dummy result + ELSE + OVER 0 SWAP PREPARE-RND-BLOCK UPDATE \ xt blk1 blk2 hash1 + OVER 0 SWAP PREPARE-RND-BLOCK UPDATE \ xt blk1 blk2 hash1 hash2 + 2>R \ xt blk1 blk2 + FLUSH \ xt blk1 blk2 + OVER 0 SWAP PREPARE-RND-BLOCK \ xt blk1 blk2 hash1' + OVER 0 SWAP PREPARE-RND-BLOCK \ xt blk1 blk2 hash1' hash2' + 2>R \ xt blk1 blk2 + ROT EXECUTE \ blk1 blk2 + FLUSH \ blk1 blk2 + SWAP BLOCK 1024 ELF-HASH \ blk2 hash1'' + SWAP BLOCK 1024 ELF-HASH \ hash1'' hash2'' + 2R> 2R> \ hash1'' hash2'' hash1' hash2' hash1 hash2 + THEN ; + +: 2= ( x1 x2 x3 x4 -- flag ) + ROT = ROT ROT = AND ; + +: TUF2-0 ( blk1 blk2 -- blk1 blk2 ) ; \ no updates +T{ ' TUF2-0 2RND-TEST-BLOCKS TUF2 \ run test procedure + 2SWAP 2DROP 2= -> TRUE }T \ compare expected and actual + +: TUF2-1 ( blk1 blk2 -- blk1 blk2 ) \ update blk1 only + OVER BLOCK DROP UPDATE ; +T{ ' TUF2-1 2RND-TEST-BLOCKS TUF2 \ run test procedure + SWAP DROP SWAP DROP 2= -> TRUE }T + +: TUF2-2 ( blk1 blk2 -- blk1 blk2 ) \ update blk2 only + DUP BUFFER DROP UPDATE ; +T{ ' TUF2-2 2RND-TEST-BLOCKS TUF2 \ run test procedure + DROP ROT DROP SWAP 2= -> TRUE }T + +: TUF2-3 ( blk1 blk2 -- blk1 blk2 ) \ update blk1 and blk2 + TUF2-1 TUF2-2 ; +T{ ' TUF2-3 2RND-TEST-BLOCKS TUF2 \ run test procedure + 2DROP 2= -> TRUE }T + +\ FLUSH and then UPDATE is ambiguous and untestable + +\ ------------------------------------------------------------------------------ +TESTING SAVE-BUFFERS + +\ In principle, all the tests above can be repeated with SAVE-BUFFERS instead of +\ FLUSH. However, only the full random test is repeated... + +T{ LIMIT-TEST-BLOCK FIRST-TEST-BLOCK WRITE-RND-BLOCKS-WITH-HASH SAVE-BUFFERS + LIMIT-TEST-BLOCK FIRST-TEST-BLOCK READ-BLOCKS-AND-HASH = -> TRUE }T + +\ FLUSH and then SAVE-BUFFERS is harmless but undetectable +\ SAVE-BUFFERS and then FLUSH is undetectable + +\ Unlike FLUSH, SAVE-BUFFERS then BUFFER/BLOCK +\ returns the original buffer address +T{ RND-TEST-BLOCK DUP BLANK-BUFFER + SAVE-BUFFERS SWAP BUFFER = -> TRUE }T +T{ RND-TEST-BLOCK DUP BLANK-BUFFER + UPDATE SAVE-BUFFERS SWAP BUFFER = -> TRUE }T +T{ RND-TEST-BLOCK DUP BLANK-BUFFER + SAVE-BUFFERS SWAP BLOCK = -> TRUE }T +T{ RND-TEST-BLOCK DUP BLANK-BUFFER + UPDATE SAVE-BUFFERS SWAP BLOCK = -> TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING BLK + +\ Signature +T{ BLK DUP ALIGNED = -> TRUE }T + +\ None of the words considered so far effect BLK +T{ BLK @ RND-TEST-BLOCK BUFFER DROP BLK @ = -> TRUE }T +T{ BLK @ RND-TEST-BLOCK BLOCK DROP BLK @ = -> TRUE }T +T{ BLK @ UPDATE BLK @ = -> TRUE }T + +T{ BLK @ FLUSH BLK @ = -> TRUE }T +T{ BLK @ SAVE-BUFFERS BLK @ = -> TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING LOAD and EVALUATE + +\ Signature: n LOAD --> blank screen +T{ RND-TEST-BLOCK DUP BLANK-BUFFER DROP UPDATE FLUSH LOAD -> }T + +T{ BLK @ RND-TEST-BLOCK DUP BLANK-BUFFER DROP UPDATE FLUSH LOAD BLK @ = -> TRUE }T + +: WRITE-BLOCK ( blk c-addr u -- ) + ROT BLANK-BUFFER SWAP CHARS MOVE UPDATE FLUSH ; + +\ blk: u; blk LOAD +: TL1 ( u blk -- ) + SWAP 0 <# #S #> WRITE-BLOCK ; +T{ BLOCK-RND RND-TEST-BLOCK 2DUP TL1 LOAD = -> TRUE }T + +\ Boundary Test: FIRST-TEST-BLOCK +T{ BLOCK-RND FIRST-TEST-BLOCK 2DUP TL1 LOAD = -> TRUE }T + +\ Boundary Test: LIMIT-TEST-BLOCK-1 +T{ BLOCK-RND LIMIT-TEST-BLOCK 1- 2DUP TL1 LOAD = -> TRUE }T + +: WRITE-AT-END-OF-BLOCK ( blk c-addr u -- ) + ROT BLANK-BUFFER + OVER 1024 SWAP - CHARS + + SWAP CHARS MOVE UPDATE FLUSH ; + +\ Boundary Test: End of Buffer +: TL2 ( u blk -- ) + SWAP 0 <# #S #> WRITE-AT-END-OF-BLOCK ; +T{ BLOCK-RND RND-TEST-BLOCK 2DUP TL2 LOAD = -> TRUE }T + +\ LOAD updates BLK +\ u: "BLK @"; u LOAD +: TL3 ( blk -- ) + S" BLK @" WRITE-BLOCK ; +T{ RND-TEST-BLOCK DUP TL3 DUP LOAD = -> TRUE }T + +\ EVALUATE resets BLK +\ u: "EVALUATE-BLK@"; u LOAD +\vf : EVALUATE-BLK@ ( -- BLK@ ) +\vf S" BLK @" EVALUATE ; +\vf : TL4 ( blk -- ) +\vf S" EVALUATE-BLK@" WRITE-BLOCK ; +\vf T{ RND-TEST-BLOCK DUP TL4 LOAD -> 0 }T + +\ EVALUTE can nest with LOAD +\ u: "BLK @"; S" u LOAD" EVALUATE +\vf : TL5 ( blk -- c-addr u ) +\vf 0 <# \ blk 0 +\vf [CHAR] D HOLD +\vf [CHAR] A HOLD +\vf [CHAR] O HOLD +\vf [CHAR] L HOLD +\vf BL HOLD +\vf #S #> ; \ c-addr u +\vf T{ RND-TEST-BLOCK DUP TL3 DUP TL5 EVALUATE = -> TRUE }T + +\ Nested LOADs +\ u2: "BLK @"; u1: "LOAD u2"; u1 LOAD +\vf : TL6 ( blk1 blk2 -- ) +\vf DUP TL3 \ blk1 blk2 +\vf TL5 WRITE-BLOCK ; +\vf T{ 2RND-TEST-BLOCKS 2DUP TL6 SWAP LOAD = -> TRUE }T + +\ LOAD changes the currect block that is effected by UPDATE +\ This test needs at least 2 distinct buffers, though this is not a +\ requirement of the language specification. If 2 distinct buffers +\ are not returned, then the tests quits with a trivial Pass +: TL7 ( blk1 blk2 -- u1 u2 rnd2 blk2-addr rnd1' rnd1 ) + OVER BUFFER OVER BUFFER = IF \ test needs 2 distinct buffers + 2DROP 0 0 0 0 0 0 \ Dummy result + ELSE + OVER BLOCK-RND DUP ROT TL1 >R \ blk1 blk2 + DUP S" SOURCE DROP" WRITE-BLOCK \ blk1 blk2 + \ change blk1 to a new rnd, but don't UPDATE + OVER BLANK-BUFFER \ blk1 blk2 blk1-addr + BLOCK-RND DUP >R \ blk1 blk2 blk1-addr rnd1' + 0 <# #S #> \ blk1 blk2 blk1-addr c-addr u + ROT SWAP CHARS MOVE \ blk1 blk2 + \ Now LOAD blk2 + DUP LOAD DUP >R \ blk1 blk2 blk2-addr + \ Write a new blk2 + DUP 1024 BL FILL \ blk1 blk2 blk2-addr + BLOCK-RND DUP >R \ blk1 blk2 blk2-addr rnd2 + 0 <# #S #> \ blk1 blk2 blk2-addr c-addr u + ROT SWAP CHARS MOVE \ blk1 blk2 + \ The following UPDATE should refer to the LOADed blk2, not blk1 + UPDATE FLUSH \ blk1 blk2 + \ Finally, load both blocks then collect all results + LOAD SWAP LOAD \ u2 u1 + R> R> R> R> \ u2 u1 rnd2 blk2-addr rnd1' rnd1 + THEN ; +T{ 2RND-TEST-BLOCKS TL7 \ run test procedure + SWAP DROP SWAP DROP \ u2 u1 rnd2 rnd1 + 2= -> TRUE }T + +\ I would expect LOAD to work on the contents of the buffer cache +\ and not the block device, but the specification doesn't say. +\ Similarly, I would not expect LOAD to FLUSH the buffer cache, +\ but the specification doesn't say so. + +\ ------------------------------------------------------------------------------ +TESTING LIST and SCR + +\ Signatures +T{ SCR DUP ALIGNED = -> TRUE }T +\ LIST signature is test implicitly in the following tests... + +: TLS1 ( blk -- ) + S" Should show a (mostly) blank screen" WRITE-BLOCK ; +T{ RND-TEST-BLOCK DUP TLS1 DUP LIST SCR @ = -> TRUE }T + +\ Boundary Test: FIRST-TEST-BLOCK +: TLS2 ( blk -- ) + S" List of the First test block" WRITE-BLOCK ; +T{ FIRST-TEST-BLOCK DUP TLS2 LIST -> }T + +\ Boundary Test: LIMIT-TEST-BLOCK +: TLS3 ( blk -- ) + S" List of the Last test block" WRITE-BLOCK ; +T{ LIMIT-TEST-BLOCK 1- DUP TLS3 LIST -> }T + +\ Boundary Test: End of Screen +: TLS4 ( blk -- ) + S" End of Screen" WRITE-AT-END-OF-BLOCK ; +T{ RND-TEST-BLOCK DUP TLS4 LIST -> }T + +\ BLOCK, BUFFER, UPDATE et al don't change SCR +: TLS5 ( blk -- ) + S" Should show another (mostly) blank screen" WRITE-BLOCK ; +\ the first test below sets the scenario for the subsequent tests +\ BLK is unchanged by LIST +T{ BLK @ RND-TEST-BLOCK DUP TLS5 LIST BLK @ = -> TRUE }T +\ SCR is unchanged by Earlier words +T{ SCR @ FLUSH SCR @ = -> TRUE }T +T{ SCR @ FLUSH DUP 1+ BUFFER DROP SCR @ = -> TRUE }T +T{ SCR @ FLUSH DUP 1+ BLOCK DROP SCR @ = -> TRUE }T +T{ SCR @ FLUSH DUP 1+ BLOCK DROP UPDATE SCR @ = -> TRUE }T +T{ SCR @ FLUSH DUP 1+ BLOCK DROP UPDATE SAVE-BUFFERS SCR @ = -> TRUE }T +: TLS6 ( blk -- ) + S" SCR @" WRITE-BLOCK ; +T{ SCR @ RND-TEST-BLOCK DUP TLS6 LOAD SCR @ OVER 2= -> TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING EMPTY-BUFFERS + +T{ EMPTY-BUFFERS -> }T +T{ BLK @ EMPTY-BUFFERS BLK @ = -> TRUE }T +T{ SCR @ EMPTY-BUFFERS SCR @ = -> TRUE }T + +\ Test R/W, but discarded changes with EMPTY-BUFFERS +T{ RND-TEST-BLOCK \ blk + DUP BLANK-BUFFER \ blk blk-addr1 + 1024 ELF-HASH \ blk hash + UPDATE FLUSH \ blk hash + OVER BLOCK CHAR \ SWAP C! \ blk hash + UPDATE EMPTY-BUFFERS FLUSH \ blk hash + SWAP BLOCK \ hash blk-addr2 + 1024 ELF-HASH = -> TRUE }T + +\ EMPTY-BUFFERS discards all buffers +: TUF2-EB ( blk1 blk2 -- blk1 blk2 ) + TUF2-1 TUF2-2 EMPTY-BUFFERS ; \ c.f. TUF2-3 +T{ ' TUF2-EB 2RND-TEST-BLOCKS TUF2 + 2SWAP 2DROP 2= -> TRUE }T + +\ FLUSH and then EMPTY-BUFFERS is acceptable but untestable +\ EMPTY-BUFFERS and then UPDATE is ambiguous and untestable + +\ ------------------------------------------------------------------------------ +TESTING >IN manipulation from a block source + +: TIN ( blk -- ) + S" 1 8 >IN +! 2 3" WRITE-BLOCK ; +T{ RND-TEST-BLOCK DUP TIN LOAD -> 1 3 }T + +\ ------------------------------------------------------------------------------ +TESTING \, SAVE-INPUT, RESTORE-INPUT and REFILL from a block source + +\ Try to determine the number of charaters per line +\ Assumes an even number of characters per line +: | ( u -- u-2 ) 2 - ; +: C/L-CALC ( blk -- c/l ) + DUP BLANK-BUFFER \ blk blk-addr + [CHAR] \ OVER C! \ blk blk-addr blk:"\" + 511 0 DO \ blk c-addr[i] + CHAR+ CHAR+ [CHAR] | OVER C! \ blk c-addr[i+1] + LOOP DROP \ blk blk:"\ | | | | ... |" + UPDATE SAVE-BUFFERS FLUSH \ blk + 1024 SWAP LOAD ; \ c/l +[?DEF] C/L +[?ELSE] +\? .( Given Characters per Line: ) C/L U. CR +[?ELSE] +\? RND-TEST-BLOCK C/L-CALC CONSTANT C/L +\? C/L 1024 U< [?IF] +\? .( Calculated Characters per Line: ) C/L U. CR +[?THEN] + +: WRITE-BLOCK-LINE ( lin-addr[i] c-addr u -- lin-addr[i+1] ) + 2>R DUP C/L CHARS + SWAP 2R> ROT SWAP MOVE ; + +\ Discards to the end of the line +: TCSIRIR1 ( blk -- ) + BLANK-BUFFER + C/L 1024 U< IF + S" 2222 \ 3333" WRITE-BLOCK-LINE + S" 4444" WRITE-BLOCK-LINE + THEN + DROP UPDATE SAVE-BUFFERS ; + +T{ RND-TEST-BLOCK DUP TCSIRIR1 LOAD -> 2222 4444 }T + +VARIABLE T-CNT 0 T-CNT ! + +: MARK ( "" -- ) \ Use between <# and #> + CHAR HOLD ; IMMEDIATE + +: ?EXECUTE ( xt f -- ) + IF EXECUTE ELSE DROP THEN ; + +\ SAVE-INPUT and RESTORE-INPUT within a single block +\vf : TCSIRIR2-EXPECTED S" EDCBCBA" ; \ Remember that the string comes out backwards +\vf : TCSIRIR2 ( blk -- ) +\vf C/L 1024 U< IF +\vf BLANK-BUFFER +\vf S" 0 T-CNT !" WRITE-BLOCK-LINE +\vf S" <# MARK A SAVE-INPUT MARK B" WRITE-BLOCK-LINE +\vf S" 1 T-CNT +! MARK C ' RESTORE-INPUT T-CNT @ 2 < ?EXECUTE MARK D" WRITE-BLOCK-LINE +\vf S" MARK E 0 0 #>" WRITE-BLOCK-LINE +\vf UPDATE SAVE-BUFFERS DROP +\vf ELSE +\vf S" 0 TCSIRIR2-EXPECTED" WRITE-BLOCK +\vf THEN ; +\vf T{ RND-TEST-BLOCK DUP TCSIRIR2 LOAD TCSIRIR2-EXPECTED S= -> 0 TRUE }T + +\ REFILL across 2 blocks +\vf : TCSIRIR3 ( blks -- ) +\vf DUP S" 1 2 3 REFILL 4 5 6" WRITE-BLOCK +\vf 1+ S" 10 11 12" WRITE-BLOCK ; +\vf T{ 2 RND-TEST-BLOCK-SEQ DUP TCSIRIR3 LOAD -> 1 2 3 -1 10 11 12 }T + +\ SAVE-INPUT and RESTORE-INPUT across 2 blocks +\vf : TCSIRIR4-EXPECTED S" HGF1ECBF1ECBA" ; \ Remember that the string comes out backwards +\vf : TCSIRIR4 ( blks -- ) +\vf C/L 1024 U< IF +\vf DUP BLANK-BUFFER +\vf S" 0 T-CNT !" WRITE-BLOCK-LINE +\vf S" <# MARK A SAVE-INPUT MARK B" WRITE-BLOCK-LINE +\vf S" MARK C REFILL MARK D" WRITE-BLOCK-LINE +\vf DROP UPDATE 1+ BLANK-BUFFER +\vf S" MARK E ABS CHAR 0 + HOLD" WRITE-BLOCK-LINE +\vf S" 1 T-CNT +! MARK F ' RESTORE-INPUT T-CNT @ 2 < ?EXECUTE MARK G" WRITE-BLOCK-LINE +\vf S" MARK H 0 0 #>" WRITE-BLOCK-LINE +\vf DROP UPDATE SAVE-BUFFERS +\vf ELSE +\vf S" 0 TCSIRIR4-EXPECTED" WRITE-BLOCK +\vf THEN ; +\vf T{ 2 RND-TEST-BLOCK-SEQ DUP TCSIRIR4 LOAD TCSIRIR4-EXPECTED S= -> 0 TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING THRU + +: TT1 ( blks -- ) + DUP S" BLK" WRITE-BLOCK + 1+ S" @" WRITE-BLOCK ; +T{ 2 RND-TEST-BLOCK-SEQ DUP TT1 DUP DUP 1+ THRU 1- = -> TRUE }T + +\ ------------------------------------------------------------------------------ + +BLOCK-ERRORS SET-ERROR-COUNT + +CR .( End of Block word tests) CR diff --git a/8080/CPM/cpmfiles/coreacpt.fth b/8080/CPM/cpmfiles/coreacpt.fth new file mode 100644 index 0000000..d629533 --- /dev/null +++ b/8080/CPM/cpmfiles/coreacpt.fth @@ -0,0 +1,35 @@ +\ From: John Hayes S1I +\ Subject: core.fr +\ Date: Mon, 27 Nov 95 13:10 + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. +\ VERSION 1.2 +\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM. +\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE +\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND +\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1. +\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"... +\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?... + +CR +TESTING CORE WORDS +HEX + +\ ------------------------------------------------------------------------ +TESTING INPUT: ACCEPT + +CREATE ABUF 50 CHARS ALLOT + +: ACCEPT-TEST + CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR + ABUF 50 ACCEPT + CR ." RECEIVED: " [CHAR] " EMIT + ABUF SWAP TYPE [CHAR] " EMIT CR +; + +T{ ACCEPT-TEST -> }T + +CR .( End of Core input word set tests) CR + + diff --git a/8080/CPM/cpmfiles/coreext.fth b/8080/CPM/cpmfiles/coreext.fth new file mode 100644 index 0000000..990ba89 --- /dev/null +++ b/8080/CPM/cpmfiles/coreext.fth @@ -0,0 +1,769 @@ +\ To test the ANS Forth Core Extension word set + +\ This program was written by Gerry Jackson in 2006, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct + +\ ------------------------------------------------------------------------------ +\ Version 0.13 28 October 2015 +\ Replace and with FALSE and TRUE to avoid +\ dependence on Core tests +\ Moved SAVE-INPUT and RESTORE-INPUT tests in a file to filetest.fth +\ Use of 2VARIABLE (from optional wordset) replaced with CREATE. +\ Minor lower to upper case conversions. +\ Calls to COMPARE replaced by S= (in utilities.fth) to avoid use +\ of a word from an optional word set. +\ UNUSED tests revised as UNUSED UNUSED = may return FALSE when an +\ implementation has the data stack sharing unused dataspace. +\ Double number input dependency removed from the HOLDS tests. +\ Minor case sensitivities removed in definition names. +\ 0.11 25 April 2015 +\ Added tests for PARSE-NAME HOLDS BUFFER: +\ S\" tests added +\ DEFER IS ACTION-OF DEFER! DEFER@ tests added +\ Empty CASE statement test added +\ [COMPILE] tests removed because it is obsolescent in Forth 2012 +\ 0.10 1 August 2014 +\ Added tests contributed by James Bowman for: +\ <> U> 0<> 0> NIP TUCK ROLL PICK 2>R 2R@ 2R> +\ HEX WITHIN UNUSED AGAIN MARKER +\ Added tests for: +\ .R U.R ERASE PAD REFILL SOURCE-ID +\ Removed ABORT from NeverExecuted to enable Win32 +\ to continue after failure of RESTORE-INPUT. +\ Removed max-intx which is no longer used. +\ 0.7 6 June 2012 Extra CASE test added +\ 0.6 1 April 2012 Tests placed in the public domain. +\ SAVE-INPUT & RESTORE-INPUT tests, position +\ of T{ moved so that tests work with ttester.fs +\ CONVERT test deleted - obsolete word removed from Forth 200X +\ IMMEDIATE VALUEs tested +\ RECURSE with :NONAME tested +\ PARSE and .( tested +\ Parsing behaviour of C" added +\ 0.5 14 September 2011 Removed the double [ELSE] from the +\ initial SAVE-INPUT & RESTORE-INPUT test +\ 0.4 30 November 2009 max-int replaced with max-intx to +\ avoid redefinition warnings. +\ 0.3 6 March 2009 { and } replaced with T{ and }T +\ CONVERT test now independent of cell size +\ 0.2 20 April 2007 ANS Forth words changed to upper case +\ Tests qd3 to qd6 by Reinhold Straub +\ 0.1 Oct 2006 First version released +\ ----------------------------------------------------------------------------- +\ The tests are based on John Hayes test program for the core word set + +\ Words tested in this file are: +\ .( .R 0<> 0> 2>R 2R> 2R@ :NONAME <> ?DO AGAIN C" CASE COMPILE, ENDCASE +\ ENDOF ERASE FALSE HEX MARKER NIP OF PAD PARSE PICK REFILL +\ RESTORE-INPUT ROLL SAVE-INPUT SOURCE-ID TO TRUE TUCK U.R U> UNUSED +\ VALUE WITHIN [COMPILE] + +\ Words not tested or partially tested: +\ \ because it has been extensively used already and is, hence, unnecessary +\ REFILL and SOURCE-ID from the user input device which are not possible +\ when testing from a file such as this one +\ UNUSED (partially tested) as the value returned is system dependent +\ Obsolescent words #TIB CONVERT EXPECT QUERY SPAN TIB as they have been +\ removed from the Forth 2012 standard + +\ Results from words that output to the user output device have to visually +\ checked for correctness. These are .R U.R .( + +\ ----------------------------------------------------------------------------- +\ Assumptions & dependencies: +\ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been +\ included prior to this file +\ - the Core word set available +\ ----------------------------------------------------------------------------- +TESTING Core Extension words + +DECIMAL + +TESTING TRUE FALSE + +T{ TRUE -> 0 INVERT }T +T{ FALSE -> 0 }T + +\ ----------------------------------------------------------------------------- +TESTING <> U> (contributed by James Bowman) + +T{ 0 0 <> -> FALSE }T +T{ 1 1 <> -> FALSE }T +T{ -1 -1 <> -> FALSE }T +T{ 1 0 <> -> TRUE }T +T{ -1 0 <> -> TRUE }T +T{ 0 1 <> -> TRUE }T +T{ 0 -1 <> -> TRUE }T + +T{ 0 1 U> -> FALSE }T +T{ 1 2 U> -> FALSE }T +T{ 0 MID-UINT U> -> FALSE }T +T{ 0 MAX-UINT U> -> FALSE }T +T{ MID-UINT MAX-UINT U> -> FALSE }T +T{ 0 0 U> -> FALSE }T +T{ 1 1 U> -> FALSE }T +T{ 1 0 U> -> TRUE }T +T{ 2 1 U> -> TRUE }T +T{ MID-UINT 0 U> -> TRUE }T +T{ MAX-UINT 0 U> -> TRUE }T +T{ MAX-UINT MID-UINT U> -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING 0<> 0> (contributed by James Bowman) + +T{ 0 0<> -> FALSE }T +T{ 1 0<> -> TRUE }T +T{ 2 0<> -> TRUE }T +T{ -1 0<> -> TRUE }T +T{ MAX-UINT 0<> -> TRUE }T +T{ MIN-INT 0<> -> TRUE }T +T{ MAX-INT 0<> -> TRUE }T + +T{ 0 0> -> FALSE }T +T{ -1 0> -> FALSE }T +T{ MIN-INT 0> -> FALSE }T +T{ 1 0> -> TRUE }T +T{ MAX-INT 0> -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING NIP TUCK ROLL PICK (contributed by James Bowman) + +T{ 1 2 NIP -> 2 }T +T{ 1 2 3 NIP -> 1 3 }T + +T{ 1 2 TUCK -> 2 1 2 }T +T{ 1 2 3 TUCK -> 1 3 2 3 }T + +T{ : RO5 100 200 300 400 500 ; -> }T +T{ RO5 3 ROLL -> 100 300 400 500 200 }T +T{ RO5 2 ROLL -> RO5 ROT }T +T{ RO5 1 ROLL -> RO5 SWAP }T +T{ RO5 0 ROLL -> RO5 }T + +T{ RO5 2 PICK -> 100 200 300 400 500 300 }T +T{ RO5 1 PICK -> RO5 OVER }T +T{ RO5 0 PICK -> RO5 DUP }T + +\ ----------------------------------------------------------------------------- +TESTING 2>R 2R@ 2R> (contributed by James Bowman) + +T{ : RR0 2>R 100 R> R> ; -> }T +T{ 300 400 RR0 -> 100 400 300 }T +T{ 200 300 400 RR0 -> 200 100 400 300 }T + +T{ : RR1 2>R 100 2R@ R> R> ; -> }T +T{ 300 400 RR1 -> 100 300 400 400 300 }T +T{ 200 300 400 RR1 -> 200 100 300 400 400 300 }T + +T{ : RR2 2>R 100 2R> ; -> }T +T{ 300 400 RR2 -> 100 300 400 }T +T{ 200 300 400 RR2 -> 200 100 300 400 }T + +\ ----------------------------------------------------------------------------- +TESTING HEX (contributed by James Bowman) + +T{ BASE @ HEX BASE @ DECIMAL BASE @ - SWAP BASE ! -> 6 }T + +\ ----------------------------------------------------------------------------- +TESTING WITHIN (contributed by James Bowman) + +T{ 0 0 0 WITHIN -> FALSE }T +T{ 0 0 MID-UINT WITHIN -> TRUE }T +T{ 0 0 MID-UINT+1 WITHIN -> TRUE }T +T{ 0 0 MAX-UINT WITHIN -> TRUE }T +T{ 0 MID-UINT 0 WITHIN -> FALSE }T +T{ 0 MID-UINT MID-UINT WITHIN -> FALSE }T +T{ 0 MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ 0 MID-UINT MAX-UINT WITHIN -> FALSE }T +T{ 0 MID-UINT+1 0 WITHIN -> FALSE }T +T{ 0 MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ 0 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ 0 MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ 0 MAX-UINT 0 WITHIN -> FALSE }T +T{ 0 MAX-UINT MID-UINT WITHIN -> TRUE }T +T{ 0 MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ 0 MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT 0 0 WITHIN -> FALSE }T +T{ MID-UINT 0 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT 0 MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT 0 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT MID-UINT 0 WITHIN -> TRUE }T +T{ MID-UINT MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MID-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT MID-UINT MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT MID-UINT+1 0 WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT 0 WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 0 0 WITHIN -> FALSE }T +T{ MID-UINT+1 0 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 0 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 0 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT 0 WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 0 WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT+1 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MAX-UINT 0 WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT 0 0 WITHIN -> FALSE }T +T{ MAX-UINT 0 MID-UINT WITHIN -> FALSE }T +T{ MAX-UINT 0 MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT 0 MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT 0 WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT+1 0 WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MAX-UINT 0 WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MID-UINT WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T + +T{ MIN-INT MIN-INT MIN-INT WITHIN -> FALSE }T +T{ MIN-INT MIN-INT 0 WITHIN -> TRUE }T +T{ MIN-INT MIN-INT 1 WITHIN -> TRUE }T +T{ MIN-INT MIN-INT MAX-INT WITHIN -> TRUE }T +T{ MIN-INT 0 MIN-INT WITHIN -> FALSE }T +T{ MIN-INT 0 0 WITHIN -> FALSE }T +T{ MIN-INT 0 1 WITHIN -> FALSE }T +T{ MIN-INT 0 MAX-INT WITHIN -> FALSE }T +T{ MIN-INT 1 MIN-INT WITHIN -> FALSE }T +T{ MIN-INT 1 0 WITHIN -> TRUE }T +T{ MIN-INT 1 1 WITHIN -> FALSE }T +T{ MIN-INT 1 MAX-INT WITHIN -> FALSE }T +T{ MIN-INT MAX-INT MIN-INT WITHIN -> FALSE }T +T{ MIN-INT MAX-INT 0 WITHIN -> TRUE }T +T{ MIN-INT MAX-INT 1 WITHIN -> TRUE }T +T{ MIN-INT MAX-INT MAX-INT WITHIN -> FALSE }T +T{ 0 MIN-INT MIN-INT WITHIN -> FALSE }T +T{ 0 MIN-INT 0 WITHIN -> FALSE }T +T{ 0 MIN-INT 1 WITHIN -> TRUE }T +T{ 0 MIN-INT MAX-INT WITHIN -> TRUE }T +T{ 0 0 MIN-INT WITHIN -> TRUE }T +T{ 0 0 0 WITHIN -> FALSE }T +T{ 0 0 1 WITHIN -> TRUE }T +T{ 0 0 MAX-INT WITHIN -> TRUE }T +T{ 0 1 MIN-INT WITHIN -> FALSE }T +T{ 0 1 0 WITHIN -> FALSE }T +T{ 0 1 1 WITHIN -> FALSE }T +T{ 0 1 MAX-INT WITHIN -> FALSE }T +T{ 0 MAX-INT MIN-INT WITHIN -> FALSE }T +T{ 0 MAX-INT 0 WITHIN -> FALSE }T +T{ 0 MAX-INT 1 WITHIN -> TRUE }T +T{ 0 MAX-INT MAX-INT WITHIN -> FALSE }T +T{ 1 MIN-INT MIN-INT WITHIN -> FALSE }T +T{ 1 MIN-INT 0 WITHIN -> FALSE }T +T{ 1 MIN-INT 1 WITHIN -> FALSE }T +T{ 1 MIN-INT MAX-INT WITHIN -> TRUE }T +T{ 1 0 MIN-INT WITHIN -> TRUE }T +T{ 1 0 0 WITHIN -> FALSE }T +T{ 1 0 1 WITHIN -> FALSE }T +T{ 1 0 MAX-INT WITHIN -> TRUE }T +T{ 1 1 MIN-INT WITHIN -> TRUE }T +T{ 1 1 0 WITHIN -> TRUE }T +T{ 1 1 1 WITHIN -> FALSE }T +T{ 1 1 MAX-INT WITHIN -> TRUE }T +T{ 1 MAX-INT MIN-INT WITHIN -> FALSE }T +T{ 1 MAX-INT 0 WITHIN -> FALSE }T +T{ 1 MAX-INT 1 WITHIN -> FALSE }T +T{ 1 MAX-INT MAX-INT WITHIN -> FALSE }T +T{ MAX-INT MIN-INT MIN-INT WITHIN -> FALSE }T +T{ MAX-INT MIN-INT 0 WITHIN -> FALSE }T +T{ MAX-INT MIN-INT 1 WITHIN -> FALSE }T +T{ MAX-INT MIN-INT MAX-INT WITHIN -> FALSE }T +T{ MAX-INT 0 MIN-INT WITHIN -> TRUE }T +T{ MAX-INT 0 0 WITHIN -> FALSE }T +T{ MAX-INT 0 1 WITHIN -> FALSE }T +T{ MAX-INT 0 MAX-INT WITHIN -> FALSE }T +T{ MAX-INT 1 MIN-INT WITHIN -> TRUE }T +T{ MAX-INT 1 0 WITHIN -> TRUE }T +T{ MAX-INT 1 1 WITHIN -> FALSE }T +T{ MAX-INT 1 MAX-INT WITHIN -> FALSE }T +T{ MAX-INT MAX-INT MIN-INT WITHIN -> TRUE }T +T{ MAX-INT MAX-INT 0 WITHIN -> TRUE }T +T{ MAX-INT MAX-INT 1 WITHIN -> TRUE }T +T{ MAX-INT MAX-INT MAX-INT WITHIN -> FALSE }T + +\ ----------------------------------------------------------------------------- +TESTING UNUSED (contributed by James Bowman & Peter Knaggs) + +VARIABLE UNUSED0 +T{ UNUSED DROP -> }T +T{ ALIGN UNUSED UNUSED0 ! 0 , UNUSED CELL+ UNUSED0 @ = -> TRUE }T +T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = + -> TRUE }T \ aligned -> unaligned +T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = -> TRUE }T \ unaligned -> ? + +\ ----------------------------------------------------------------------------- +TESTING AGAIN (contributed by James Bowman) + +T{ : AG0 701 BEGIN DUP 7 MOD 0= IF EXIT THEN 1+ AGAIN ; -> }T +T{ AG0 -> 707 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING MARKER (contributed by James Bowman) + +\vf T{ : MA? BL WORD FIND NIP 0<> ; -> }T +\vf T{ MARKER MA0 -> }T +\vf T{ : MA1 111 ; -> }T +\vf T{ MARKER MA2 -> }T +\vf T{ : MA1 222 ; -> }T +\vf T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE TRUE }T +\vf T{ MA1 MA2 MA1 -> 222 111 }T +\vf T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE FALSE }T +\vf T{ MA0 -> }T +\vf T{ MA? MA0 MA? MA1 MA? MA2 -> FALSE FALSE FALSE }T + +\ ----------------------------------------------------------------------------- +TESTING ?DO + +: QD ?DO I LOOP ; +T{ 789 789 QD -> }T +T{ -9876 -9876 QD -> }T +T{ 5 0 QD -> 0 1 2 3 4 }T + +: QD1 ?DO I 10 +LOOP ; +T{ 50 1 QD1 -> 1 11 21 31 41 }T +T{ 50 0 QD1 -> 0 10 20 30 40 }T + +: QD2 ?DO I 3 > IF LEAVE ELSE I THEN LOOP ; +T{ 5 -1 QD2 -> -1 0 1 2 3 }T + +: QD3 ?DO I 1 +LOOP ; +T{ 4 4 QD3 -> }T +T{ 4 1 QD3 -> 1 2 3 }T +T{ 2 -1 QD3 -> -1 0 1 }T + +: QD4 ?DO I -1 +LOOP ; +T{ 4 4 QD4 -> }T +T{ 1 4 QD4 -> 4 3 2 1 }T +T{ -1 2 QD4 -> 2 1 0 -1 }T + +: QD5 ?DO I -10 +LOOP ; +T{ 1 50 QD5 -> 50 40 30 20 10 }T +T{ 0 50 QD5 -> 50 40 30 20 10 0 }T +T{ -25 10 QD5 -> 10 0 -10 -20 }T + +VARIABLE ITERS +VARIABLE INCRMNT + +: QD6 ( limit start increment -- ) + INCRMNT ! + 0 ITERS ! + ?DO + 1 ITERS +! + I + ITERS @ 6 = IF LEAVE THEN + INCRMNT @ + +LOOP ITERS @ +; + +T{ 4 4 -1 QD6 -> 0 }T +T{ 1 4 -1 QD6 -> 4 3 2 1 4 }T +T{ 4 1 -1 QD6 -> 1 0 -1 -2 -3 -4 6 }T +T{ 4 1 0 QD6 -> 1 1 1 1 1 1 6 }T +T{ 0 0 0 QD6 -> 0 }T +T{ 1 4 0 QD6 -> 4 4 4 4 4 4 6 }T +T{ 1 4 1 QD6 -> 4 5 6 7 8 9 6 }T +T{ 4 1 1 QD6 -> 1 2 3 3 }T +T{ 4 4 1 QD6 -> 0 }T +T{ 2 -1 -1 QD6 -> -1 -2 -3 -4 -5 -6 6 }T +T{ -1 2 -1 QD6 -> 2 1 0 -1 4 }T +T{ 2 -1 0 QD6 -> -1 -1 -1 -1 -1 -1 6 }T +T{ -1 2 0 QD6 -> 2 2 2 2 2 2 6 }T +T{ -1 2 1 QD6 -> 2 3 4 5 6 7 6 }T +T{ 2 -1 1 QD6 -> -1 0 1 3 }T + +\ ----------------------------------------------------------------------------- +TESTING BUFFER: + +T{ 8 BUFFER: BUF:TEST -> }T +T{ BUF:TEST DUP ALIGNED = -> TRUE }T +T{ 111 BUF:TEST ! 222 BUF:TEST CELL+ ! -> }T +T{ BUF:TEST @ BUF:TEST CELL+ @ -> 111 222 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING VALUE TO + +\vf T{ 111 VALUE VAL1 -999 VALUE VAL2 -> }T +\vf T{ VAL1 -> 111 }T +\vf T{ VAL2 -> -999 }T +\vf T{ 222 TO VAL1 -> }T +\vf T{ VAL1 -> 222 }T +\vf T{ : VD1 VAL1 ; -> }T +\vf T{ VD1 -> 222 }T +\vf T{ : VD2 TO VAL2 ; -> }T +\vf T{ VAL2 -> -999 }T +\vf T{ -333 VD2 -> }T +\vf T{ VAL2 -> -333 }T +\vf T{ VAL1 -> 222 }T +\vf T{ 123 VALUE VAL3 IMMEDIATE VAL3 -> 123 }T +\vf T{ : VD3 VAL3 LITERAL ; VD3 -> 123 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING CASE OF ENDOF ENDCASE + +\vf : CS1 CASE 1 OF 111 ENDOF +\vf 2 OF 222 ENDOF +\vf 3 OF 333 ENDOF +\vf >R 999 R> +\vf ENDCASE +\vf ; + +\vf T{ 1 CS1 -> 111 }T +\vf T{ 2 CS1 -> 222 }T +\vf T{ 3 CS1 -> 333 }T +\vf T{ 4 CS1 -> 999 }T + +\ Nested CASE's + +\vf : CS2 >R CASE -1 OF CASE R@ 1 OF 100 ENDOF +\vf 2 OF 200 ENDOF +\vf >R -300 R> +\vf ENDCASE +\vf ENDOF +\vf -2 OF CASE R@ 1 OF -99 ENDOF +\vf >R -199 R> +\vf ENDCASE +\vf ENDOF +\vf >R 299 R> +\vf ENDCASE R> DROP +\vf ; + +\vf T{ -1 1 CS2 -> 100 }T +\vf T{ -1 2 CS2 -> 200 }T +\vf T{ -1 3 CS2 -> -300 }T +\vf T{ -2 1 CS2 -> -99 }T +\vf T{ -2 2 CS2 -> -199 }T +\vf T{ 0 2 CS2 -> 299 }T + +\ Boolean short circuiting using CASE + +\vf : CS3 ( N1 -- N2 ) +\vf CASE 1- FALSE OF 11 ENDOF +\vf 1- FALSE OF 22 ENDOF +\vf 1- FALSE OF 33 ENDOF +\vf 44 SWAP +\vf ENDCASE +\vf ; + +\vf T{ 1 CS3 -> 11 }T +\vf T{ 2 CS3 -> 22 }T +\vf T{ 3 CS3 -> 33 }T +\vf T{ 9 CS3 -> 44 }T + +\ Empty CASE statements with/without default + +\vf T{ : CS4 CASE ENDCASE ; 1 CS4 -> }T +\vf T{ : CS5 CASE 2 SWAP ENDCASE ; 1 CS5 -> 2 }T +\vf T{ : CS6 CASE 1 OF ENDOF 2 ENDCASE ; 1 CS6 -> }T +\vf T{ : CS7 CASE 3 OF ENDOF 2 ENDCASE ; 1 CS7 -> 1 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING :NONAME RECURSE + +\vf VARIABLE NN1 +\vf VARIABLE NN2 +\vf :NONAME 1234 ; NN1 ! +\vf :NONAME 9876 ; NN2 ! +\vf T{ NN1 @ EXECUTE -> 1234 }T +\vf T{ NN2 @ EXECUTE -> 9876 }T + +\vf T{ :NONAME ( n -- 0,1,..n ) DUP IF DUP >R 1- RECURSE R> THEN ; +\vf CONSTANT RN1 -> }T +\vf T{ 0 RN1 EXECUTE -> 0 }T +\vf T{ 4 RN1 EXECUTE -> 0 1 2 3 4 }T + +\vf :NONAME ( n -- n1 ) \ Multiple RECURSEs in one definition +\vf 1- DUP +\vf CASE 0 OF EXIT ENDOF +\vf 1 OF 11 SWAP RECURSE ENDOF +\vf 2 OF 22 SWAP RECURSE ENDOF +\vf 3 OF 33 SWAP RECURSE ENDOF +\vf DROP ABS RECURSE EXIT +\vf ENDCASE +\vf ; CONSTANT RN2 + +\vf T{ 1 RN2 EXECUTE -> 0 }T +\vf T{ 2 RN2 EXECUTE -> 11 0 }T +\vf T{ 4 RN2 EXECUTE -> 33 22 11 0 }T +\vf T{ 25 RN2 EXECUTE -> 33 22 11 0 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING C" + +T{ : CQ1 C" 123" ; -> }T +\vf T{ CQ1 COUNT EVALUATE -> 123 }T +T{ : CQ2 C" " ; -> }T +\vf T{ CQ2 COUNT EVALUATE -> }T +\vf T{ : CQ3 C" 2345"COUNT EVALUATE ; CQ3 -> 2345 }T + +\ ----------------------------------------------------------------------------- +TESTING COMPILE, + +:NONAME DUP + ; CONSTANT DUP+ +T{ : Q DUP+ COMPILE, ; -> }T +T{ : AS1 [ Q ] ; -> }T +T{ 123 AS1 -> 246 }T + +\ ----------------------------------------------------------------------------- +\ Cannot automatically test SAVE-INPUT and RESTORE-INPUT from a console source + +\vf TESTING SAVE-INPUT and RESTORE-INPUT with a string source + +\vf VARIABLE SI_INC 0 SI_INC ! + +\vf : SI1 +\vf SI_INC @ >IN +! +\vf 15 SI_INC ! +\vf ; + +\vf : S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ; + +\vf T{ S$ EVALUATE SI_INC @ -> 0 2345 15 }T + +\ ----------------------------------------------------------------------------- +TESTING .( + +CR CR .( Output from .() +T{ CR .( You should see -9876: ) -9876 . -> }T +T{ CR .( and again: ).( -9876)CR -> }T + +CR CR .( On the next 2 lines you should see First then Second messages:) +T{ : DOTP CR ." Second message via ." [CHAR] " EMIT \ Check .( is immediate + [ CR ] .( First message via .( ) ; DOTP -> }T +CR CR +T{ : IMM? BL WORD FIND NIP ; IMM? .( -> 1 }T + +\ ----------------------------------------------------------------------------- +TESTING .R and U.R - has to handle different cell sizes + +\ Create some large integers just below/above MAX and Min INTs +MAX-INT 73 79 */ CONSTANT LI1 +MIN-INT 71 73 */ CONSTANT LI2 + +LI1 0 <# #S #> NIP CONSTANT LENLI1 + +: (.R&U.R) ( u1 u2 -- ) \ u1 <= string length, u2 is required indentation + TUCK + >R + LI1 OVER SPACES . CR R@ LI1 SWAP .R CR + LI2 OVER SPACES . CR R@ 1+ LI2 SWAP .R CR + LI1 OVER SPACES U. CR R@ LI1 SWAP U.R CR + LI2 SWAP SPACES U. CR R> LI2 SWAP U.R CR +; + +: .R&U.R ( -- ) + CR ." You should see lines duplicated:" CR + ." indented by 0 spaces" CR 0 0 (.R&U.R) CR + ." indented by 0 spaces" CR LENLI1 0 (.R&U.R) CR \ Just fits required width + ." indented by 5 spaces" CR LENLI1 5 (.R&U.R) CR +; + +CR CR .( Output from .R and U.R) +T{ .R&U.R -> }T + +\ ----------------------------------------------------------------------------- +TESTING PAD ERASE +\ Must handle different size characters i.e. 1 CHARS >= 1 + +84 CONSTANT CHARS/PAD \ Minimum size of PAD in chars +CHARS/PAD CHARS CONSTANT AUS/PAD +: CHECKPAD ( caddr u ch -- f ) \ f = TRUE if u chars = ch + SWAP 0 + ?DO + OVER I CHARS + C@ OVER <> + IF 2DROP UNLOOP FALSE EXIT THEN + LOOP + 2DROP TRUE +; + +T{ PAD DROP -> }T +T{ 0 INVERT PAD C! -> }T +T{ PAD C@ CONSTANT MAXCHAR -> }T +T{ PAD CHARS/PAD 2DUP MAXCHAR FILL MAXCHAR CHECKPAD -> TRUE }T +T{ PAD CHARS/PAD 2DUP CHARS ERASE 0 CHECKPAD -> TRUE }T +T{ PAD CHARS/PAD 2DUP MAXCHAR FILL PAD 0 ERASE MAXCHAR CHECKPAD -> TRUE }T +T{ PAD 43 CHARS + 9 CHARS ERASE -> }T +T{ PAD 43 MAXCHAR CHECKPAD -> TRUE }T +T{ PAD 43 CHARS + 9 0 CHECKPAD -> TRUE }T +T{ PAD 52 CHARS + CHARS/PAD 52 - MAXCHAR CHECKPAD -> TRUE }T + +\ Check that use of WORD and pictured numeric output do not corrupt PAD +\ Minimum size of buffers for these are 33 chars and (2*n)+2 chars respectively +\ where n is number of bits per cell + +PAD CHARS/PAD ERASE +2 BASE ! +MAX-UINT MAX-UINT <# #S CHAR 1 DUP HOLD HOLD #> 2DROP +DECIMAL +BL WORD 12345678123456781234567812345678 DROP +T{ PAD CHARS/PAD 0 CHECKPAD -> TRUE }T + +\ ----------------------------------------------------------------------------- +\vf TESTING PARSE + +\vf T{ CHAR | PARSE 1234| DUP ROT ROT EVALUATE -> 4 1234 }T +\vf T{ CHAR ^ PARSE 23 45 ^ DUP ROT ROT EVALUATE -> 7 23 45 }T +\vf : PA1 [CHAR] $ PARSE DUP >R PAD SWAP CHARS MOVE PAD R> ; +\vf T{ PA1 3456 +\vf DUP ROT ROT EVALUATE -> 4 3456 }T +\vf T{ CHAR A PARSE A SWAP DROP -> 0 }T +\vf T{ CHAR Z PARSE +\vf SWAP DROP -> 0 }T +\vf T{ CHAR " PARSE 4567 "DUP ROT ROT EVALUATE -> 5 4567 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING PARSE-NAME (Forth 2012) +\ Adapted from the PARSE-NAME RfD tests +\vf T{ PARSE-NAME abcd STR1 S= -> TRUE }T \ No leading spaces +\vf T{ PARSE-NAME abcde STR2 S= -> TRUE }T \ Leading spaces + +\ Test empty parse area, new lines are necessary +\vf T{ PARSE-NAME +\vf NIP -> 0 }T +\ Empty parse area with spaces after PARSE-NAME +\vf T{ PARSE-NAME +\vf NIP -> 0 }T + +\vf T{ : PARSE-NAME-TEST ( "name1" "name2" -- n ) +\vf PARSE-NAME PARSE-NAME S= ; -> }T +\vf T{ PARSE-NAME-TEST abcd abcd -> TRUE }T +\vf T{ PARSE-NAME-TEST abcd abcd -> TRUE }T \ Leading spaces +\vf T{ PARSE-NAME-TEST abcde abcdf -> FALSE }T +\vf T{ PARSE-NAME-TEST abcdf abcde -> FALSE }T +\vf T{ PARSE-NAME-TEST abcde abcde +\vf -> TRUE }T \ Parse to end of line +\vf T{ PARSE-NAME-TEST abcde abcde +\vf -> TRUE }T \ Leading and trailing spaces + +\ ----------------------------------------------------------------------------- +TESTING DEFER DEFER@ DEFER! IS ACTION-OF (Forth 2012) +\ Adapted from the Forth 200X RfD tests + +T{ DEFER DEFER1 -> }T +T{ : MY-DEFER DEFER ; -> }T +T{ : IS-DEFER1 IS DEFER1 ; -> }T +T{ : ACTION-DEFER1 ACTION-OF DEFER1 ; -> }T +T{ : DEF! DEFER! ; -> }T +T{ : DEF@ DEFER@ ; -> }T + +T{ ' * ' DEFER1 DEFER! -> }T +T{ 2 3 DEFER1 -> 6 }T +T{ ' DEFER1 DEFER@ -> ' * }T +T{ ' DEFER1 DEF@ -> ' * }T +T{ ACTION-OF DEFER1 -> ' * }T +T{ ACTION-DEFER1 -> ' * }T +T{ ' + IS DEFER1 -> }T +T{ 1 2 DEFER1 -> 3 }T +T{ ' DEFER1 DEFER@ -> ' + }T +T{ ' DEFER1 DEF@ -> ' + }T +T{ ACTION-OF DEFER1 -> ' + }T +T{ ACTION-DEFER1 -> ' + }T +T{ ' - IS-DEFER1 -> }T +T{ 1 2 DEFER1 -> -1 }T +T{ ' DEFER1 DEFER@ -> ' - }T +T{ ' DEFER1 DEF@ -> ' - }T +T{ ACTION-OF DEFER1 -> ' - }T +T{ ACTION-DEFER1 -> ' - }T + +T{ MY-DEFER DEFER2 -> }T +T{ ' DUP IS DEFER2 -> }T +T{ 1 DEFER2 -> 1 1 }T + +\ ----------------------------------------------------------------------------- +TESTING HOLDS (Forth 2012) + +: HTEST S" Testing HOLDS" ; +: HTEST2 S" works" ; +: HTEST3 S" Testing HOLDS works 123" ; +T{ 0 0 <# HTEST HOLDS #> HTEST S= -> TRUE }T +T{ 123 0 <# #S BL HOLD HTEST2 HOLDS BL HOLD HTEST HOLDS #> + HTEST3 S= -> TRUE }T +T{ : HLD HOLDS ; -> }T +T{ 0 0 <# HTEST HLD #> HTEST S= -> TRUE }T + +\ ----------------------------------------------------------------------------- +\vf TESTING REFILL SOURCE-ID +\ REFILL and SOURCE-ID from the user input device can't be tested from a file, +\ can only be tested from a string via EVALUATE + +\vf T{ : RF1 S" REFILL" EVALUATE ; RF1 -> FALSE }T +\vf T{ : SID1 S" SOURCE-ID" EVALUATE ; SID1 -> -1 }T + +\ ------------------------------------------------------------------------------ +\vf TESTING S\" (Forth 2012 compilation mode) +\ Extended the Forth 200X RfD tests +\ Note this tests the Core Ext definition of S\" which has unedfined +\ interpretation semantics. S\" in interpretation mode is tested in the tests on +\ the File-Access word set + +\vf T{ : SSQ1 S\" abc" S" abc" S= ; -> }T \ No escapes +\vf T{ SSQ1 -> TRUE }T +\vf T{ : SSQ2 S\" " ; SSQ2 SWAP DROP -> 0 }T \ Empty string + +\vf T{ : SSQ3 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T +\vf T{ SSQ3 SWAP DROP -> 20 }T \ String length +\vf T{ SSQ3 DROP C@ -> 7 }T \ \a BEL Bell +\vf T{ SSQ3 DROP 1 CHARS + C@ -> 8 }T \ \b BS Backspace +\vf T{ SSQ3 DROP 2 CHARS + C@ -> 27 }T \ \e ESC Escape +\vf T{ SSQ3 DROP 3 CHARS + C@ -> 12 }T \ \f FF Form feed +\vf T{ SSQ3 DROP 4 CHARS + C@ -> 10 }T \ \l LF Line feed +\vf T{ SSQ3 DROP 5 CHARS + C@ -> 13 }T \ \m CR of CR/LF pair +\vf T{ SSQ3 DROP 6 CHARS + C@ -> 10 }T \ LF of CR/LF pair +\vf T{ SSQ3 DROP 7 CHARS + C@ -> 34 }T \ \q " Double Quote +\vf T{ SSQ3 DROP 8 CHARS + C@ -> 13 }T \ \r CR Carriage Return +\vf T{ SSQ3 DROP 9 CHARS + C@ -> 9 }T \ \t TAB Horizontal Tab +\vf T{ SSQ3 DROP 10 CHARS + C@ -> 11 }T \ \v VT Vertical Tab +\vf T{ SSQ3 DROP 11 CHARS + C@ -> 15 }T \ \x0F Given Char +\vf T{ SSQ3 DROP 12 CHARS + C@ -> 48 }T \ 0 0 Digit follow on +\vf T{ SSQ3 DROP 13 CHARS + C@ -> 31 }T \ \x1F Given Char +\vf T{ SSQ3 DROP 14 CHARS + C@ -> 97 }T \ a a Hex follow on +\vf T{ SSQ3 DROP 15 CHARS + C@ -> 171 }T \ \xaB Insensitive Given Char +\vf T{ SSQ3 DROP 16 CHARS + C@ -> 120 }T \ x x Non hex follow on +\vf T{ SSQ3 DROP 17 CHARS + C@ -> 0 }T \ \z NUL No Character +\vf T{ SSQ3 DROP 18 CHARS + C@ -> 34 }T \ \" " Double Quote +\vf T{ SSQ3 DROP 19 CHARS + C@ -> 92 }T \ \\ \ Back Slash + +\ The above does not test \n as this is a system dependent value. +\ Check it displays a new line +\vf CR .( The next test should display:) +\vf CR .( One line...) +\vf CR .( another line) +\vf T{ : SSQ4 S\" \nOne line...\nanotherLine\n" type ; SSQ4 -> }T + +\ Test bare escapable characters appear as themselves +\vf T{ : SSQ5 S\" abeflmnqrtvxz" S" abeflmnqrtvxz" S= ; SSQ5 -> TRUE }T + +\vf T{ : SSQ6 S\" a\""2DROP 1111 ; SSQ6 -> 1111 }T \ Parsing behaviour + +\vf T{ : SSQ7 S\" 111 : SSQ8 s\\\" 222\" EVALUATE ; SSQ8 333" EVALUATE ; -> }T +\vf T{ SSQ7 -> 111 222 333 }T +\vf T{ : SSQ9 S\" 11 : SSQ10 s\\\" \\x32\\x32\" EVALUATE ; SSQ10 33" EVALUATE ; -> }T +\vf T{ SSQ9 -> 11 22 33 }T + +\ ----------------------------------------------------------------------------- +CORE-EXT-ERRORS SET-ERROR-COUNT + +CR .( End of Core Extension word tests) CR + + diff --git a/8080/CPM/cpmfiles/coreplus.fth b/8080/CPM/cpmfiles/coreplus.fth new file mode 100644 index 0000000..82b1be2 --- /dev/null +++ b/8080/CPM/cpmfiles/coreplus.fth @@ -0,0 +1,306 @@ +\ Additional tests on the the ANS Forth Core word set + +\ This program was written by Gerry Jackson in 2007, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct + +\ ------------------------------------------------------------------------------ +\ The tests are based on John Hayes test program for the core word set +\ +\ This file provides some more tests on Core words where the original Hayes +\ tests are thought to be incomplete +\ +\ Words tested in this file are: +\ DO I +LOOP RECURSE ELSE >IN IMMEDIATE FIND IF...BEGIN...REPEAT ALLOT DOES> +\ and +\ Parsing behaviour +\ Number prefixes # $ % and 'A' character input +\ Definition names +\ ------------------------------------------------------------------------------ +\ Assumptions and dependencies: +\ - tester.fr or ttester.fs has been loaded prior to this file +\ - core.fr has been loaded so that constants MAX-INT, MIN-INT and +\ MAX-UINT are defined +\ ------------------------------------------------------------------------------ + +DECIMAL + +TESTING DO +LOOP with run-time increment, negative increment, infinite loop +\ Contributed by Reinhold Straub + +VARIABLE ITERATIONS +VARIABLE INCREMENT +: GD7 ( LIMIT START INCREMENT -- ) + INCREMENT ! + 0 ITERATIONS ! + DO + 1 ITERATIONS +! + I + ITERATIONS @ 6 = IF LEAVE THEN + INCREMENT @ + +LOOP ITERATIONS @ +; + +T{ 4 4 -1 GD7 -> 4 1 }T +T{ 1 4 -1 GD7 -> 4 3 2 1 4 }T +T{ 4 1 -1 GD7 -> 1 0 -1 -2 -3 -4 6 }T +T{ 4 1 0 GD7 -> 1 1 1 1 1 1 6 }T +T{ 0 0 0 GD7 -> 0 0 0 0 0 0 6 }T +T{ 1 4 0 GD7 -> 4 4 4 4 4 4 6 }T +T{ 1 4 1 GD7 -> 4 5 6 7 8 9 6 }T +T{ 4 1 1 GD7 -> 1 2 3 3 }T +T{ 4 4 1 GD7 -> 4 5 6 7 8 9 6 }T +T{ 2 -1 -1 GD7 -> -1 -2 -3 -4 -5 -6 6 }T +T{ -1 2 -1 GD7 -> 2 1 0 -1 4 }T +T{ 2 -1 0 GD7 -> -1 -1 -1 -1 -1 -1 6 }T +T{ -1 2 0 GD7 -> 2 2 2 2 2 2 6 }T +T{ -1 2 1 GD7 -> 2 3 4 5 6 7 6 }T +T{ 2 -1 1 GD7 -> -1 0 1 3 }T +T{ -20 30 -10 GD7 -> 30 20 10 0 -10 -20 6 }T +T{ -20 31 -10 GD7 -> 31 21 11 1 -9 -19 6 }T +T{ -20 29 -10 GD7 -> 29 19 9 -1 -11 5 }T + +\ ------------------------------------------------------------------------------ +TESTING DO +LOOP with large and small increments + +\ Contributed by Andrew Haley + +MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP +USTEP NEGATE CONSTANT -USTEP +MAX-INT 7 RSHIFT 1+ CONSTANT STEP +STEP NEGATE CONSTANT -STEP + +VARIABLE BUMP + +T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; -> }T + +T{ 0 MAX-UINT 0 USTEP GD8 -> 256 }T +T{ 0 0 MAX-UINT -USTEP GD8 -> 256 }T + +T{ 0 MAX-INT MIN-INT STEP GD8 -> 256 }T +T{ 0 MIN-INT MAX-INT -STEP GD8 -> 256 }T + +\ Two's complement arithmetic, wraps around modulo wordsize +\ Only tested if the Forth system does wrap around, use of conditional +\ compilation deliberately avoided + +MAX-INT 1+ MIN-INT = CONSTANT +WRAP? +MIN-INT 1- MAX-INT = CONSTANT -WRAP? +MAX-UINT 1+ 0= CONSTANT +UWRAP? +0 1- MAX-UINT = CONSTANT -UWRAP? + +: GD9 ( n limit start step f result -- ) + >R IF GD8 ELSE 2DROP 2DROP R@ THEN -> R> }T +; + +T{ 0 0 0 USTEP +UWRAP? 256 GD9 +T{ 0 0 0 -USTEP -UWRAP? 1 GD9 +T{ 0 MIN-INT MAX-INT STEP +WRAP? 1 GD9 +T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9 + +\ ------------------------------------------------------------------------------ +TESTING DO +LOOP with maximum and minimum increments + +: (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ; +(-MI) CONSTANT -MAX-INT + +T{ 0 1 0 MAX-INT GD8 -> 1 }T +T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8 -> 2 }T + +T{ 0 MAX-INT 0 MAX-INT GD8 -> 1 }T +T{ 0 MAX-INT 1 MAX-INT GD8 -> 1 }T +T{ 0 MAX-INT -1 MAX-INT GD8 -> 2 }T +T{ 0 MAX-INT DUP 1- MAX-INT GD8 -> 1 }T + +T{ 0 MIN-INT 1+ 0 MIN-INT GD8 -> 1 }T +T{ 0 MIN-INT 1+ -1 MIN-INT GD8 -> 1 }T +T{ 0 MIN-INT 1+ 1 MIN-INT GD8 -> 2 }T +T{ 0 MIN-INT 1+ DUP MIN-INT GD8 -> 1 }T + +\ ------------------------------------------------------------------------------ +\ TESTING +LOOP setting I to an arbitrary value + +\ The specification for +LOOP permits the loop index I to be set to any value +\ including a value outside the range given to the corresponding DO. + +\ SET-I is a helper to set I in a DO ... +LOOP to a given value +\ n2 is the value of I in a DO ... +LOOP +\ n3 is a test value +\ If n2=n3 then return n1-n2 else return 1 +: SET-I ( n1 n2 n3 -- n1-n2 | 1 ) + OVER = IF - ELSE 2DROP 1 THEN +; + +: -SET-I ( n1 n2 n3 -- n1-n2 | -1 ) + SET-I DUP 1 = IF NEGATE THEN +; + +: PL1 20 1 DO I 18 I 3 SET-I +LOOP ; +T{ PL1 -> 1 2 3 18 19 }T +: PL2 20 1 DO I 20 I 2 SET-I +LOOP ; +T{ PL2 -> 1 2 }T +: PL3 20 5 DO I 19 I 2 SET-I DUP 1 = IF DROP 0 I 6 SET-I THEN +LOOP ; +T{ PL3 -> 5 6 0 1 2 19 }T +: PL4 20 1 DO I MAX-INT I 4 SET-I +LOOP ; +T{ PL4 -> 1 2 3 4 }T +: PL5 -20 -1 DO I -19 I -3 -SET-I +LOOP ; +T{ PL5 -> -1 -2 -3 -19 -20 }T +: PL6 -20 -1 DO I -21 I -4 -SET-I +LOOP ; +T{ PL6 -> -1 -2 -3 -4 }T +: PL7 -20 -1 DO I MIN-INT I -5 -SET-I +LOOP ; +T{ PL7 -> -1 -2 -3 -4 -5 }T +: PL8 -20 -5 DO I -20 I -2 -SET-I DUP -1 = IF DROP 0 I -6 -SET-I THEN +LOOP ; +T{ PL8 -> -5 -6 0 -1 -2 -20 }T + +\ ------------------------------------------------------------------------------ +TESTING multiple RECURSEs in one colon definition + +: ACK ( m n -- u ) \ Ackermann function, from Rosetta Code + OVER 0= IF NIP 1+ EXIT THEN \ ack(0, n) = n+1 + SWAP 1- SWAP ( -- m-1 n ) + DUP 0= IF 1+ RECURSE EXIT THEN \ ack(m, 0) = ack(m-1, 1) + 1- OVER 1+ SWAP RECURSE RECURSE \ ack(m, n) = ack(m-1, ack(m,n-1)) +; + +T{ 0 0 ACK -> 1 }T +T{ 3 0 ACK -> 5 }T +T{ 2 4 ACK -> 11 }T + +\ ------------------------------------------------------------------------------ +\vf TESTING multiple ELSE's in an IF statement +\ Discussed on comp.lang.forth and accepted as valid ANS Forth + +\vf : MELSE IF 1 ELSE 2 ELSE 3 ELSE 4 ELSE 5 THEN ; +\vf T{ 0 MELSE -> 2 4 }T +\vf T{ -1 MELSE -> 1 3 5 }T + +\ ------------------------------------------------------------------------------ +TESTING manipulation of >IN in interpreter mode + +T{ 12345 DEPTH OVER 9 < 34 AND + 3 + >IN ! -> 12345 2345 345 45 5 }T +T{ 14145 8115 ?DUP 0= 34 AND >IN +! TUCK MOD 14 >IN ! GCD CALCULATION -> 15 }T + +\ ------------------------------------------------------------------------------ +TESTING IMMEDIATE with CONSTANT VARIABLE and CREATE [ ... DOES> ] + +T{ 123 CONSTANT IW1 IMMEDIATE IW1 -> 123 }T +T{ : IW2 IW1 LITERAL ; IW2 -> 123 }T +T{ VARIABLE IW3 IMMEDIATE 234 IW3 ! IW3 @ -> 234 }T +T{ : IW4 IW3 [ @ ] LITERAL ; IW4 -> 234 }T +T{ :NONAME [ 345 ] IW3 [ ! ] ; DROP IW3 @ -> 345 }T +T{ CREATE IW5 456 , IMMEDIATE -> }T +T{ :NONAME IW5 [ @ IW3 ! ] ; DROP IW3 @ -> 456 }T +T{ : IW6 CREATE , IMMEDIATE DOES> @ 1+ ; -> }T +T{ 111 IW6 IW7 IW7 -> 112 }T +T{ : IW8 IW7 LITERAL 1+ ; IW8 -> 113 }T +T{ : IW9 CREATE , DOES> @ 2 + IMMEDIATE ; -> }T +: FIND-IW BL WORD FIND NIP ; ( -- 0 | 1 | -1 ) +T{ 222 IW9 IW10 FIND-IW IW10 -> -1 }T \ IW10 is not immediate +T{ IW10 FIND-IW IW10 -> 224 1 }T \ IW10 becomes immediate + +\ ------------------------------------------------------------------------------ +TESTING that IMMEDIATE doesn't toggle a flag + +VARIABLE IT1 0 IT1 ! +: IT2 1234 IT1 ! ; IMMEDIATE IMMEDIATE +T{ : IT3 IT2 ; IT1 @ -> 1234 }T + +\ ------------------------------------------------------------------------------ +TESTING parsing behaviour of S" ." and ( +\ which should parse to just beyond the terminating character no space needed + +T{ : GC5 S" A string"2DROP ; GC5 -> }T +T{ ( A comment)1234 -> 1234 }T +T{ : PB1 CR ." You should see 2345: "." 2345"( A comment) CR ; PB1 -> }T + +\ ------------------------------------------------------------------------------ +TESTING number prefixes # $ % and 'c' character input +\ Adapted from the Forth 200X Draft 14.5 document + +VARIABLE OLD-BASE +DECIMAL BASE @ OLD-BASE ! +T{ &1289 -> 1289 }T \ vf: s/#/&/ +T{ -&1289 -> -1289 }T \ vf: s/#-/-&/ +T{ $12eF -> 4847 }T +T{ -$12eF -> -4847 }T \ vf: s/$-/-$/ +T{ %10010110 -> 150 }T +T{ -%10010110 -> -150 }T \ vf: s/%-/-%/ +\vf T{ 'z' -> 122 }T +\vf T{ 'Z' -> 90 }T +\ Check BASE is unchanged +T{ BASE @ OLD-BASE @ = -> }T + +\ Repeat in Hex mode +16 OLD-BASE ! 16 BASE ! +T{ &1289 -> 509 }T \ vf: s/#/&/ +T{ -&1289 -> -509 }T \ vf: s/#/&/ +T{ $12eF -> 12EF }T +T{ -$12eF -> -12EF }T \ vf: s/$-/-$/ +T{ %10010110 -> 96 }T +T{ -%10010110 -> -96 }T \ vf: s/%-/-%/ +\vf T{ 'z' -> 7a }T +\vf T{ 'Z' -> 5a }T +\ Check BASE is unchanged +T{ BASE @ OLD-BASE @ = -> }T \ 2 + +DECIMAL +\ Check number prefixes in compile mode +\ vf: s/#/&/ s/$-/-$/ s/'''/ascii '/ +T{ : nmp &8327 -$2cbe %011010111 ascii ' ; nmp -> 8327 -11454 215 39 }T + +\ ------------------------------------------------------------------------------ +TESTING definition names +\ should support {1..31} graphical characters +: !"#$%&'()*+,-./0123456789:;<=>? 1 ; +T{ !"#$%&'()*+,-./0123456789:;<=>? -> 1 }T +: @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ 2 ; +T{ @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ -> 2 }T +: _`abcdefghijklmnopqrstuvwxyz{|} 3 ; +T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T +: _`abcdefghijklmnopqrstuvwxyz{|~ 4 ; \ Last character different +T{ _`abcdefghijklmnopqrstuvwxyz{|~ -> 4 }T +T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T + +\ ------------------------------------------------------------------------------ +TESTING FIND with a zero length string and a non-existent word + +CREATE EMPTYSTRING 0 C, +: EMPTYSTRING-FIND-CHECK ( c-addr 0 | xt 1 | xt -1 -- t|f ) + DUP IF ." FIND returns a TRUE value for an empty string!" CR THEN + 0= SWAP EMPTYSTRING = = ; +T{ EMPTYSTRING FIND EMPTYSTRING-FIND-CHECK -> }T + +CREATE NON-EXISTENT-WORD \ Same as in exceptiontest.fth + 15 C, CHAR $ C, CHAR $ C, CHAR Q C, CHAR W C, CHAR E C, CHAR Q C, + CHAR W C, CHAR E C, CHAR Q C, CHAR W C, CHAR E C, CHAR R C, CHAR T C, + CHAR $ C, CHAR $ C, +T{ NON-EXISTENT-WORD FIND -> NON-EXISTENT-WORD 0 }T + +\ ------------------------------------------------------------------------------ +\vf TESTING IF ... BEGIN ... REPEAT (unstructured) + +\vf T{ : UNS1 DUP 0 > IF 9 SWAP BEGIN 1+ DUP 3 > IF EXIT THEN REPEAT ; -> }T +\vf T{ -6 UNS1 -> -6 }T +\vf T{ 1 UNS1 -> 9 4 }T + +\ ------------------------------------------------------------------------------ +TESTING DOES> doesn't cause a problem with a CREATEd address + +: MAKE-2CONST DOES> 2@ ; +T{ CREATE 2K 3 , 2K , MAKE-2CONST 2K -> ' 2K >BODY 3 }T + +\ ------------------------------------------------------------------------------ +TESTING ALLOT ( n -- ) where n <= 0 + +T{ HERE 5 ALLOT -5 ALLOT HERE = -> }T +T{ HERE 0 ALLOT HERE = -> }T + +\ ------------------------------------------------------------------------------ + +CR .( End of additional Core tests) CR diff --git a/8080/CPM/cpmfiles/doubltst.fth b/8080/CPM/cpmfiles/doubltst.fth new file mode 100644 index 0000000..0f3f3b3 --- /dev/null +++ b/8080/CPM/cpmfiles/doubltst.fth @@ -0,0 +1,438 @@ +\ To test the ANS Forth Double-Number word set and double number extensions + +\ This program was written by Gerry Jackson in 2006, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct +\ ------------------------------------------------------------------------------ +\ Version 0.13 Assumptions and dependencies changed +\ 0.12 1 August 2015 test D< acts on MS cells of double word +\ 0.11 7 April 2015 2VALUE tested +\ 0.6 1 April 2012 Tests placed in the public domain. +\ Immediate 2CONSTANTs and 2VARIABLEs tested +\ 0.5 20 November 2009 Various constants renamed to avoid +\ redefinition warnings. and replaced +\ with TRUE and FALSE +\ 0.4 6 March 2009 { and } replaced with T{ and }T +\ Tests rewritten to be independent of word size and +\ tests re-ordered +\ 0.3 20 April 2007 ANS Forth words changed to upper case +\ 0.2 30 Oct 2006 Updated following GForth test to include +\ various constants from core.fr +\ 0.1 Oct 2006 First version released +\ ------------------------------------------------------------------------------ +\ The tests are based on John Hayes test program for the core word set + +\ Words tested in this file are: +\ 2CONSTANT 2LITERAL 2VARIABLE D+ D- D. D.R D0< D0= D2* D2/ +\ D< D= D>S DABS DMAX DMIN DNEGATE M*/ M+ 2ROT DU< +\ Also tests the interpreter and compiler reading a double number +\ ------------------------------------------------------------------------------ +\ Assumptions and dependencies: +\ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been +\ included prior to this file +\ - the Core word set is available and tested +\ ------------------------------------------------------------------------------ +\ Constant definitions + +DECIMAL +0 INVERT CONSTANT 1SD +1SD 1 RSHIFT CONSTANT MAX-INTD \ 01...1 +MAX-INTD INVERT CONSTANT MIN-INTD \ 10...0 +MAX-INTD 2/ CONSTANT HI-INT \ 001...1 +MIN-INTD 2/ CONSTANT LO-INT \ 110...1 + +\ ------------------------------------------------------------------------------ +TESTING interpreter and compiler reading double numbers, with/without prefixes + +T{ 1. -> 1 0 }T +T{ -2. -> -2 -1 }T +T{ : RDL1 3. ; RDL1 -> 3 0 }T +T{ : RDL2 -4. ; RDL2 -> -4 -1 }T + +VARIABLE OLD-DBASE +DECIMAL BASE @ OLD-DBASE ! +T{ &12346789. -> 12346789. }T \ vf: s/#/&/ +T{ -&12346789. -> -12346789. }T \ vf: s/#-/-&/ +T{ $12aBcDeF. -> 313249263. }T +T{ -$12AbCdEf. -> -313249263. }T \ vf: s/$-/-$/ +T{ %10010110. -> 150. }T +T{ -%10010110. -> -150. }T \ vf: s/%-/-%/ +\ Check BASE is unchanged +T{ BASE @ OLD-DBASE @ = -> }T + +\ Repeat in Hex mode +16 OLD-DBASE ! 16 BASE ! +T{ &12346789. -> BC65A5. }T \ vf: s/#/&/ +T{ -&12346789. -> -BC65A5. }T \ vf: s/#-/-&/ +T{ $12aBcDeF. -> 12AbCdeF. }T +T{ -$12AbCdEf. -> -12ABCDef. }T \ vf: s/$-/-$/ +T{ %10010110. -> 96. }T +T{ -%10010110. -> -96. }T \ vf: s/%-/-%/ +\ Check BASE is unchanged +T{ BASE @ OLD-DBASE @ = -> }T \ 2 + +DECIMAL +\ Check number prefixes in compile mode +\ vf: s/#/&/ s/$-/-$/ +T{ : dnmp &8327. -$2cbe. %011010111. ; dnmp -> 8327. -11454. 215. }T + +\ ------------------------------------------------------------------------------ +TESTING 2CONSTANT + +T{ 1 2 2CONSTANT 2C1 -> }T +T{ 2C1 -> 1 2 }T +T{ : CD1 2C1 ; -> }T +T{ CD1 -> 1 2 }T +T{ : CD2 2CONSTANT ; -> }T +T{ -1 -2 CD2 2C2 -> }T +T{ 2C2 -> -1 -2 }T +T{ 4 5 2CONSTANT 2C3 IMMEDIATE 2C3 -> 4 5 }T +T{ : CD6 2C3 2LITERAL ; CD6 -> 4 5 }T + +\ ------------------------------------------------------------------------------ +\ Some 2CONSTANTs for the following tests + +1SD MAX-INTD 2CONSTANT MAX-2INT \ 01...1 +0 MIN-INTD 2CONSTANT MIN-2INT \ 10...0 +MAX-2INT 2/ 2CONSTANT HI-2INT \ 001...1 +MIN-2INT 2/ 2CONSTANT LO-2INT \ 110...0 + +\ ------------------------------------------------------------------------------ +TESTING DNEGATE + +T{ 0. DNEGATE -> 0. }T +T{ 1. DNEGATE -> -1. }T +T{ -1. DNEGATE -> 1. }T +T{ MAX-2INT DNEGATE -> MIN-2INT SWAP 1+ SWAP }T +T{ MIN-2INT SWAP 1+ SWAP DNEGATE -> MAX-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D+ with small integers + +T{ 0. 5. D+ -> 5. }T +T{ -5. 0. D+ -> -5. }T +T{ 1. 2. D+ -> 3. }T +T{ 1. -2. D+ -> -1. }T +T{ -1. 2. D+ -> 1. }T +T{ -1. -2. D+ -> -3. }T +T{ -1. 1. D+ -> 0. }T + +TESTING D+ with mid range integers + +T{ 0 0 0 5 D+ -> 0 5 }T +T{ -1 5 0 0 D+ -> -1 5 }T +T{ 0 0 0 -5 D+ -> 0 -5 }T +T{ 0 -5 -1 0 D+ -> -1 -5 }T +T{ 0 1 0 2 D+ -> 0 3 }T +T{ -1 1 0 -2 D+ -> -1 -1 }T +T{ 0 -1 0 2 D+ -> 0 1 }T +T{ 0 -1 -1 -2 D+ -> -1 -3 }T +T{ -1 -1 0 1 D+ -> -1 0 }T +T{ MIN-INTD 0 2DUP D+ -> 0 1 }T +T{ MIN-INTD S>D MIN-INTD 0 D+ -> 0 0 }T + +TESTING D+ with large double integers + +T{ HI-2INT 1. D+ -> 0 HI-INT 1+ }T +T{ HI-2INT 2DUP D+ -> 1SD 1- MAX-INTD }T +T{ MAX-2INT MIN-2INT D+ -> -1. }T +T{ MAX-2INT LO-2INT D+ -> HI-2INT }T +T{ HI-2INT MIN-2INT D+ 1. D+ -> LO-2INT }T +T{ LO-2INT 2DUP D+ -> MIN-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D- with small integers + +T{ 0. 5. D- -> -5. }T +T{ 5. 0. D- -> 5. }T +T{ 0. -5. D- -> 5. }T +T{ 1. 2. D- -> -1. }T +T{ 1. -2. D- -> 3. }T +T{ -1. 2. D- -> -3. }T +T{ -1. -2. D- -> 1. }T +T{ -1. -1. D- -> 0. }T + +TESTING D- with mid-range integers + +T{ 0 0 0 5 D- -> 0 -5 }T +T{ -1 5 0 0 D- -> -1 5 }T +T{ 0 0 -1 -5 D- -> 1 4 }T +T{ 0 -5 0 0 D- -> 0 -5 }T +T{ -1 1 0 2 D- -> -1 -1 }T +T{ 0 1 -1 -2 D- -> 1 2 }T +T{ 0 -1 0 2 D- -> 0 -3 }T +T{ 0 -1 0 -2 D- -> 0 1 }T +T{ 0 0 0 1 D- -> 0 -1 }T +T{ MIN-INTD 0 2DUP D- -> 0. }T +T{ MIN-INTD S>D MAX-INTD 0 D- -> 1 1SD }T + +TESTING D- with large integers + +T{ MAX-2INT MAX-2INT D- -> 0. }T +T{ MIN-2INT MIN-2INT D- -> 0. }T +T{ MAX-2INT HI-2INT D- -> LO-2INT DNEGATE }T +T{ HI-2INT LO-2INT D- -> MAX-2INT }T +T{ LO-2INT HI-2INT D- -> MIN-2INT 1. D+ }T +T{ MIN-2INT MIN-2INT D- -> 0. }T +T{ MIN-2INT LO-2INT D- -> LO-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D0< D0= + +T{ 0. D0< -> FALSE }T +T{ 1. D0< -> FALSE }T +T{ MIN-INTD 0 D0< -> FALSE }T +T{ 0 MAX-INTD D0< -> FALSE }T +T{ MAX-2INT D0< -> FALSE }T +T{ -1. D0< -> TRUE }T +T{ MIN-2INT D0< -> TRUE }T + +T{ 1. D0= -> FALSE }T +T{ MIN-INTD 0 D0= -> FALSE }T +T{ MAX-2INT D0= -> FALSE }T +T{ -1 MAX-INTD D0= -> FALSE }T +T{ 0. D0= -> TRUE }T +T{ -1. D0= -> FALSE }T +T{ 0 MIN-INTD D0= -> FALSE }T + +\ ------------------------------------------------------------------------------ +TESTING D2* D2/ + +T{ 0. D2* -> 0. D2* }T +T{ MIN-INTD 0 D2* -> 0 1 }T +T{ HI-2INT D2* -> MAX-2INT 1. D- }T +T{ LO-2INT D2* -> MIN-2INT }T + +T{ 0. D2/ -> 0. }T +T{ 1. D2/ -> 0. }T +T{ 0 1 D2/ -> MIN-INTD 0 }T +T{ MAX-2INT D2/ -> HI-2INT }T +T{ -1. D2/ -> -1. }T +T{ MIN-2INT D2/ -> LO-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D< D= + +T{ 0. 1. D< -> TRUE }T +T{ 0. 0. D< -> FALSE }T +T{ 1. 0. D< -> FALSE }T +T{ -1. 1. D< -> TRUE }T +T{ -1. 0. D< -> TRUE }T +T{ -2. -1. D< -> TRUE }T +T{ -1. -2. D< -> FALSE }T +T{ 0 1 1. D< -> FALSE }T \ Suggested by Helmut Eller +T{ 1. 0 1 D< -> TRUE }T +T{ 0 -1 1 -2 D< -> FALSE }T +T{ 1 -2 0 -1 D< -> TRUE }T +T{ -1. MAX-2INT D< -> TRUE }T +T{ MIN-2INT MAX-2INT D< -> TRUE }T +T{ MAX-2INT -1. D< -> FALSE }T +T{ MAX-2INT MIN-2INT D< -> FALSE }T +T{ MAX-2INT 2DUP -1. D+ D< -> FALSE }T +T{ MIN-2INT 2DUP 1. D+ D< -> TRUE }T +T{ MAX-INTD S>D 2DUP 1. D+ D< -> TRUE }T \ Ensure D< acts on MS cells + +T{ -1. -1. D= -> TRUE }T +T{ -1. 0. D= -> FALSE }T +T{ -1. 1. D= -> FALSE }T +T{ 0. -1. D= -> FALSE }T +T{ 0. 0. D= -> TRUE }T +T{ 0. 1. D= -> FALSE }T +T{ 1. -1. D= -> FALSE }T +T{ 1. 0. D= -> FALSE }T +T{ 1. 1. D= -> TRUE }T + +T{ 0 -1 0 -1 D= -> TRUE }T +T{ 0 -1 0 0 D= -> FALSE }T +T{ 0 -1 0 1 D= -> FALSE }T +T{ 0 0 0 -1 D= -> FALSE }T +T{ 0 0 0 0 D= -> TRUE }T +T{ 0 0 0 1 D= -> FALSE }T +T{ 0 1 0 -1 D= -> FALSE }T +T{ 0 1 0 0 D= -> FALSE }T +T{ 0 1 0 1 D= -> TRUE }T + +T{ MAX-2INT MIN-2INT D= -> FALSE }T +T{ MAX-2INT 0. D= -> FALSE }T +T{ MAX-2INT MAX-2INT D= -> TRUE }T +T{ MAX-2INT HI-2INT D= -> FALSE }T +T{ MAX-2INT MIN-2INT D= -> FALSE }T +T{ MIN-2INT MIN-2INT D= -> TRUE }T +T{ MIN-2INT LO-2INT D= -> FALSE }T +T{ MIN-2INT MAX-2INT D= -> FALSE }T + +\ ------------------------------------------------------------------------------ +TESTING 2LITERAL 2VARIABLE + +T{ : CD3 [ MAX-2INT ] 2LITERAL ; -> }T +T{ CD3 -> MAX-2INT }T +T{ 2VARIABLE 2V1 -> }T +T{ 0. 2V1 2! -> }T +T{ 2V1 2@ -> 0. }T +T{ -1 -2 2V1 2! -> }T +T{ 2V1 2@ -> -1 -2 }T +T{ : CD4 2VARIABLE ; -> }T +T{ CD4 2V2 -> }T +T{ : CD5 2V2 2! ; -> }T +T{ -2 -1 CD5 -> }T +T{ 2V2 2@ -> -2 -1 }T +T{ 2VARIABLE 2V3 IMMEDIATE 5 6 2V3 2! -> }T +T{ 2V3 2@ -> 5 6 }T +T{ : CD7 2V3 [ 2@ ] 2LITERAL ; CD7 -> 5 6 }T +T{ : CD8 [ 6 7 ] 2V3 [ 2! ] ; 2V3 2@ -> 6 7 }T + +\ ------------------------------------------------------------------------------ +TESTING DMAX DMIN + +T{ 1. 2. DMAX -> 2. }T +T{ 1. 0. DMAX -> 1. }T +T{ 1. -1. DMAX -> 1. }T +T{ 1. 1. DMAX -> 1. }T +T{ 0. 1. DMAX -> 1. }T +T{ 0. -1. DMAX -> 0. }T +T{ -1. 1. DMAX -> 1. }T +T{ -1. -2. DMAX -> -1. }T + +T{ MAX-2INT HI-2INT DMAX -> MAX-2INT }T +T{ MAX-2INT MIN-2INT DMAX -> MAX-2INT }T +T{ MIN-2INT MAX-2INT DMAX -> MAX-2INT }T +T{ MIN-2INT LO-2INT DMAX -> LO-2INT }T + +T{ MAX-2INT 1. DMAX -> MAX-2INT }T +T{ MAX-2INT -1. DMAX -> MAX-2INT }T +T{ MIN-2INT 1. DMAX -> 1. }T +T{ MIN-2INT -1. DMAX -> -1. }T + + +T{ 1. 2. DMIN -> 1. }T +T{ 1. 0. DMIN -> 0. }T +T{ 1. -1. DMIN -> -1. }T +T{ 1. 1. DMIN -> 1. }T +T{ 0. 1. DMIN -> 0. }T +T{ 0. -1. DMIN -> -1. }T +T{ -1. 1. DMIN -> -1. }T +T{ -1. -2. DMIN -> -2. }T + +T{ MAX-2INT HI-2INT DMIN -> HI-2INT }T +T{ MAX-2INT MIN-2INT DMIN -> MIN-2INT }T +T{ MIN-2INT MAX-2INT DMIN -> MIN-2INT }T +T{ MIN-2INT LO-2INT DMIN -> MIN-2INT }T + +T{ MAX-2INT 1. DMIN -> 1. }T +T{ MAX-2INT -1. DMIN -> -1. }T +T{ MIN-2INT 1. DMIN -> MIN-2INT }T +T{ MIN-2INT -1. DMIN -> MIN-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D>S DABS + +T{ 1234 0 D>S -> 1234 }T +T{ -1234 -1 D>S -> -1234 }T +T{ MAX-INTD 0 D>S -> MAX-INTD }T +T{ MIN-INTD -1 D>S -> MIN-INTD }T + +T{ 1. DABS -> 1. }T +T{ -1. DABS -> 1. }T +T{ MAX-2INT DABS -> MAX-2INT }T +T{ MIN-2INT 1. D+ DABS -> MAX-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING M+ M*/ + +T{ HI-2INT 1 M+ -> HI-2INT 1. D+ }T +T{ MAX-2INT -1 M+ -> MAX-2INT -1. D+ }T +T{ MIN-2INT 1 M+ -> MIN-2INT 1. D+ }T +T{ LO-2INT -1 M+ -> LO-2INT -1. D+ }T + +\ To correct the result if the division is floored, only used when +\ necessary i.e. negative quotient and remainder <> 0 + +: ?FLOORED [ -3 2 / -2 = ] LITERAL IF 1. D- THEN ; + +\vf T{ 5. 7 11 M*/ -> 3. }T +\vf T{ 5. -7 11 M*/ -> -3. ?FLOORED }T \ FLOORED -4. +\vf T{ -5. 7 11 M*/ -> -3. ?FLOORED }T \ FLOORED -4. +\vf T{ -5. -7 11 M*/ -> 3. }T +\vf T{ MAX-2INT 8 16 M*/ -> HI-2INT }T +\vf T{ MAX-2INT -8 16 M*/ -> HI-2INT DNEGATE ?FLOORED }T \ FLOORED SUBTRACT 1 +\vf T{ MIN-2INT 8 16 M*/ -> LO-2INT }T +\vf T{ MIN-2INT -8 16 M*/ -> LO-2INT DNEGATE }T +\vf T{ MAX-2INT MAX-INTD MAX-INTD M*/ -> MAX-2INT }T +\vf T{ MAX-2INT MAX-INTD 2/ MAX-INTD M*/ -> MAX-INTD 1- HI-2INT NIP }T +\vf T{ MIN-2INT LO-2INT NIP 1+ DUP 1- NEGATE M*/ -> 0 MAX-INTD 1- }T +\vf T{ MIN-2INT LO-2INT NIP 1- MAX-INTD M*/ -> MIN-INTD 3 + HI-2INT NIP 2 + }T +\vf T{ MAX-2INT LO-2INT NIP DUP NEGATE M*/ -> MAX-2INT DNEGATE }T +\vf T{ MIN-2INT MAX-INTD DUP M*/ -> MIN-2INT }T + +\ ------------------------------------------------------------------------------ +\vf TESTING D. D.R + +\ Create some large double numbers +\vf MAX-2INT 71 73 M*/ 2CONSTANT DBL1 +\vf MIN-2INT 73 79 M*/ 2CONSTANT DBL2 + +\vf : D>ASCII ( D -- CADDR U ) +\vf DUP >R <# DABS #S R> SIGN #> ( -- CADDR1 U ) +\vf HERE SWAP 2DUP 2>R CHARS DUP ALLOT MOVE 2R> +\vf ; + +\vf DBL1 D>ASCII 2CONSTANT "DBL1" +\vf DBL2 D>ASCII 2CONSTANT "DBL2" + +\vf : DOUBLEOUTPUT +\vf CR ." You should see lines duplicated:" CR +\vf 5 SPACES "DBL1" TYPE CR +\vf 5 SPACES DBL1 D. CR +\vf 8 SPACES "DBL1" DUP >R TYPE CR +\vf 5 SPACES DBL1 R> 3 + D.R CR +\vf 5 SPACES "DBL2" TYPE CR +\vf 5 SPACES DBL2 D. CR +\vf 10 SPACES "DBL2" DUP >R TYPE CR +\vf 5 SPACES DBL2 R> 5 + D.R CR +\vf ; + +\vf T{ DOUBLEOUTPUT -> }T + +\ ------------------------------------------------------------------------------ +TESTING 2ROT DU< (Double Number extension words) + +T{ 1. 2. 3. 2ROT -> 2. 3. 1. }T +T{ MAX-2INT MIN-2INT 1. 2ROT -> MIN-2INT 1. MAX-2INT }T + +\vf T{ 1. 1. DU< -> FALSE }T +\vf T{ 1. -1. DU< -> TRUE }T +\vf T{ -1. 1. DU< -> FALSE }T +\vf T{ -1. -2. DU< -> FALSE }T +\vf T{ 0 1 1. DU< -> FALSE }T +\vf T{ 1. 0 1 DU< -> TRUE }T +\vf T{ 0 -1 1 -2 DU< -> FALSE }T +\vf T{ 1 -2 0 -1 DU< -> TRUE }T + +\vf T{ MAX-2INT HI-2INT DU< -> FALSE }T +\vf T{ HI-2INT MAX-2INT DU< -> TRUE }T +\vf T{ MAX-2INT MIN-2INT DU< -> TRUE }T +\vf T{ MIN-2INT MAX-2INT DU< -> FALSE }T +\vf T{ MIN-2INT LO-2INT DU< -> TRUE }T + +\ ------------------------------------------------------------------------------ +\vf TESTING 2VALUE + +\vf T{ 1111 2222 2VALUE 2VAL -> }T +\vf T{ 2VAL -> 1111 2222 }T +\vf T{ 3333 4444 TO 2VAL -> }T +\vf T{ 2VAL -> 3333 4444 }T +\vf T{ : TO-2VAL TO 2VAL ; 5555 6666 TO-2VAL -> }T +\vf T{ 2VAL -> 5555 6666 }T + +\ ------------------------------------------------------------------------------ + +DOUBLE-ERRORS SET-ERROR-COUNT + +CR .( End of Double-Number word tests) CR + diff --git a/8080/CPM/cpmfiles/errorrep.fth b/8080/CPM/cpmfiles/errorrep.fth new file mode 100644 index 0000000..24e7bd1 --- /dev/null +++ b/8080/CPM/cpmfiles/errorrep.fth @@ -0,0 +1,88 @@ +\ To collect and report on the number of errors resulting from running the +\ ANS Forth and Forth 2012 test programs + +\ This program was written by Gerry Jackson in 2015, and is in the public +\ domain - it can be distributed and/or modified in any way but please +\ retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ ------------------------------------------------------------------------------ +\ This file is INCLUDED after Core tests are complete and only uses Core words +\ already tested. The purpose of this file is to count errors in test results +\ and present them as a summary at the end of the tests. + +DECIMAL + +VARIABLE TOTAL-ERRORS + +: ERROR-COUNT ( "name" n1 -- n2 ) \ n2 = n1 + 1cell + CREATE DUP , CELL+ + DOES> ( -- offset ) @ \ offset in address units +; + +0 \ Offset into ERRORS[] array +ERROR-COUNT CORE-ERRORS ERROR-COUNT CORE-EXT-ERRORS +ERROR-COUNT DOUBLE-ERRORS ERROR-COUNT EXCEPTION-ERRORS +ERROR-COUNT FACILITY-ERRORS ERROR-COUNT FILE-ERRORS +ERROR-COUNT LOCALS-ERRORS ERROR-COUNT MEMORY-ERRORS +ERROR-COUNT SEARCHORDER-ERRORS ERROR-COUNT STRING-ERRORS +ERROR-COUNT TOOLS-ERRORS ERROR-COUNT BLOCK-ERRORS +CREATE ERRORS[] DUP ALLOT CONSTANT #ERROR-COUNTS + +\ SET-ERROR-COUNT called at the end of each test file with its own offset into +\ the ERRORS[] array. #ERRORS is in files tester.fr and ttester.fs + +: SET-ERROR-COUNT ( offset -- ) + #ERRORS @ SWAP ERRORS[] + ! + #ERRORS @ TOTAL-ERRORS +! + 0 #ERRORS ! +; + +: INIT-ERRORS ( -- ) + ERRORS[] #ERROR-COUNTS OVER + SWAP DO -1 I ! 1 CELLS +LOOP + 0 TOTAL-ERRORS ! + CORE-ERRORS SET-ERROR-COUNT +; + +INIT-ERRORS + +\ Report summary of errors + +25 CONSTANT MARGIN + +: SHOW-ERROR-LINE ( n caddr u -- ) + CR SWAP OVER TYPE MARGIN - ABS >R + DUP -1 = IF DROP R> 1- SPACES ." -" ELSE + R> .R THEN +; + +: SHOW-ERROR-COUNT ( caddr u offset -- ) + ERRORS[] + @ ROT ROT SHOW-ERROR-LINE +; + +: HLINE ( -- ) CR ." ---------------------------" ; + +: REPORT-ERRORS + HLINE + CR 8 SPACES ." Error Report" + CR ." Word Set" 13 SPACES ." Errors" + HLINE + S" Core" CORE-ERRORS SHOW-ERROR-COUNT + S" Core extension" CORE-EXT-ERRORS SHOW-ERROR-COUNT + S" Block" BLOCK-ERRORS SHOW-ERROR-COUNT + S" Double number" DOUBLE-ERRORS SHOW-ERROR-COUNT + S" Exception" EXCEPTION-ERRORS SHOW-ERROR-COUNT + S" Facility" FACILITY-ERRORS SHOW-ERROR-COUNT + S" File-access" FILE-ERRORS SHOW-ERROR-COUNT + S" Locals" LOCALS-ERRORS SHOW-ERROR-COUNT + S" Memory-allocation" MEMORY-ERRORS SHOW-ERROR-COUNT + S" Programming-tools" TOOLS-ERRORS SHOW-ERROR-COUNT + S" Search-order" SEARCHORDER-ERRORS SHOW-ERROR-COUNT + S" String" STRING-ERRORS SHOW-ERROR-COUNT + HLINE + TOTAL-ERRORS @ S" Total" SHOW-ERROR-LINE + HLINE CR CR +; diff --git a/8080/CPM/cpmfiles/incltest.fth b/8080/CPM/cpmfiles/incltest.fth new file mode 100644 index 0000000..02da693 --- /dev/null +++ b/8080/CPM/cpmfiles/incltest.fth @@ -0,0 +1,10 @@ + +\needs (type include extend.fb include multi.vid include dos.fb +include log2file.fb +logopen output.log + +.( hello, world) cr +: test-hello ." hello, world, from test-hello" cr ; +test-hello + +logclose diff --git a/8080/CPM/cpmfiles/include.fb b/8080/CPM/cpmfiles/include.fb index ee99b71..b6ef618 100644 --- a/8080/CPM/cpmfiles/include.fb +++ b/8080/CPM/cpmfiles/include.fb @@ -1 +1 @@ -\ include for stream sources for cp/m phz 30aug23 \ load screen phz 02sep23 onlyforth dos also forth definitions : idos-error? ( n -- f ) 0<> ; : iread-seq ( dosfcb -- f ) $14 bdosa idos-error? ; : cr+ex@ ( fcb -- cr+256*ex ) dup &34 + c@ swap &14 + c@ $100 * + ; : cr+ex! ( cr+256*ex fcb -- ) >r $100 u/mod r@ &14 + c! r> &34 + c! ; 1 7 +thru \ fib /fib #fib eolf? phz 07mai23 context @ dos also context ! $50 constant /tib variable tibeof tibeof off $1a constant ctrl-z : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN ctrl-z = IF tibeof on 1 ELSE -1 THEN ; \ incfile incpos inc-fgetc phz 02sep23 variable incfile variable increc variable rec-offset $80 constant dmabuf | $ff constant dmabuf-last : readrec ( fcb -- f ) dup cr+ex@ increc ! rec-offset off dmabuf dma! drive iread-seq ; : inc-fgetc ( -- c ) rec-offset @ b/rec u< 0= IF incfile @ readrec IF ctrl-z exit THEN THEN rec-offset @ dmabuf + c@ 1 rec-offset +! ; \ freadline probe-for-fb phz 25aug23 : freadline ( -- eof ) tib /tib bounds DO inc-fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN inc-fgetc eolf? 1+ UNTIL tibeof @ ; | : probe-for-fb ( -- flag ) dmabuf BEGIN dup c@ #lf = IF drop 0 exit THEN 1+ dup dmabuf-last u> UNTIL drop 1 ; \ save/restoretib phz 06okt22 $50 constant /stash create stash[ /stash allot here constant ]stash variable stash> stash[ stash> ! : savetib ( -- n ) #tib @ >in @ - dup stash> @ + ]stash u> abort" tib stash overflow" >r tib >in @ + stash> @ r@ cmove r@ stash> +! r> ; : restoretib ( n -- ) dup >r negate stash> +! stash> @ tib r@ cmove r> #tib ! >in off ; \ interpret-via-tib inner-include phz 02sep23 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include-inner ( -- ) increc push 0 isfile@ cr+ex! isfile@ readrec Abort" can't read start of file" probe-for-fb IF 1 load exit THEN incfile push isfile@ incfile ! savetib >r interpret-via-tib close r> restoretib ; \ include phz 02sep23 : include ( -- ) rec-offset push isfile push fromfile push use cr file? include-inner incfile @ IF increc @ incfile @ cr+ex! incfile @ readrec Abort" error re-reading after include" THEN ; \ \ phz 02sep23 : (stashquit stash[ stash> ! incfile off increc off (quit ; : stashrestore ['] (stashquit IS 'quit ; ' stashrestore IS 'restart : \ blk @ IF >in @ negate c/l mod >in +! ELSE #tib @ >in ! THEN ; immediate \ : \needs have 0=exit \ blk @ IF >in @ negate c/l mod >in +! \ ELSE #tib @ >in ! THEN ; \ No newline at end of file +\ include for stream sources for cp/m phz 30aug23 \ load screen phz 02sep23 onlyforth dos also forth definitions : idos-error? ( n -- f ) 0<> ; : iread-seq ( dosfcb -- f ) $14 bdosa idos-error? ; : cr+ex@ ( fcb -- cr+256*ex ) dup &34 + c@ swap &14 + c@ $100 * + ; : cr+ex! ( cr+256*ex fcb -- ) >r $100 u/mod r@ &14 + c! r> &34 + c! ; 1 7 +thru \ fib /fib #fib eolf? phz 09okt24 context @ dos also context ! \ $50 constant /tib variable tibeof tibeof off $1a constant ctrl-z : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN ctrl-z = IF tibeof on 1 ELSE -1 THEN ; \ incfile incpos inc-fgetc phz 02sep23 variable incfile variable increc variable rec-offset $80 constant dmabuf | $ff constant dmabuf-last : readrec ( fcb -- f ) dup cr+ex@ increc ! rec-offset off dmabuf dma! drive iread-seq ; : inc-fgetc ( -- c ) rec-offset @ b/rec u< 0= IF incfile @ readrec IF ctrl-z exit THEN THEN rec-offset @ dmabuf + c@ 1 rec-offset +! ; \ freadline probe-for-fb phz 25aug23 : freadline ( -- eof ) tib /tib bounds DO inc-fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN inc-fgetc eolf? 1+ UNTIL tibeof @ ; | : probe-for-fb ( -- flag ) dmabuf BEGIN dup c@ #lf = IF drop 0 exit THEN 1+ dup dmabuf-last u> UNTIL drop 1 ; \ save/restoretib phz 06okt22 $50 constant /stash create stash[ /stash allot here constant ]stash variable stash> stash[ stash> ! : savetib ( -- n ) #tib @ >in @ - dup stash> @ + ]stash u> abort" tib stash overflow" >r tib >in @ + stash> @ r@ cmove r@ stash> +! r> ; : restoretib ( n -- ) dup >r negate stash> +! stash> @ tib r@ cmove r> #tib ! >in off ; \ interpret-via-tib inner-include phz 02sep23 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include-inner ( -- ) increc push 0 isfile@ cr+ex! isfile@ readrec Abort" can't read start of file" probe-for-fb IF 1 load exit THEN incfile push isfile@ incfile ! savetib >r interpret-via-tib close r> restoretib ; \ include phz 02sep23 : include ( -- ) rec-offset push isfile push fromfile push use cr file? include-inner incfile @ IF increc @ incfile @ cr+ex! incfile @ readrec Abort" error re-reading after include" THEN ; \ \ phz 02sep23 : (stashquit stash[ stash> ! incfile off increc off (quit ; : stashrestore ['] (stashquit IS 'quit ; ' stashrestore IS 'restart : \ blk @ IF >in @ negate c/l mod >in +! ELSE #tib @ >in ! THEN ; immediate \ : \needs have 0=exit \ blk @ IF >in @ negate c/l mod >in +! \ ELSE #tib @ >in ! THEN ; \ No newline at end of file diff --git a/8080/CPM/cpmfiles/log2file.fth b/8080/CPM/cpmfiles/log2file.fth new file mode 100644 index 0000000..80cfe45 --- /dev/null +++ b/8080/CPM/cpmfiles/log2file.fth @@ -0,0 +1,95 @@ + +\ *** Block No. 0, Hexblock 0 + + + + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ log2file loadscreen phz 20aug23 + + 1 3 +thru + +\\ + : .1x ( n -- ) $30 + dup $39 > IF 7 + THEN (emit ; + + : .4x ( n -- ) + ascii $ (emit 4 0 DO $10 u/mod LOOP drop .1x .1x .1x .1x + $20 (emit ; + + : .2x ( n -- ) + ascii $ (emit 2 0 DO $10 u/mod LOOP drop .1x .1x + $20 (emit ; + + + +\ *** Block No. 2, Hexblock 2 + +\ logfile phz 20aug23 + + Dos also Forth definitions + + $18 constant fcb\nam + create logfile ," LOGFILE TXT" fcb\nam allot 1 logfile c! + create logdma b/rec allot + variable logoffset 0 logoffset ! + + : logflush logdma dma! logfile $15 bdos $80 dma! ; + + : logc! ( c -- ) + logoffset @ dup >r logdma + c! r> 1+ + dup logoffset ! b/rec = + IF logflush 0 logoffset ! THEN ; + + +\ *** Block No. 3, Hexblock 3 + +\ log-emit log-type log-cr alsologtofile pphz 03sep23 + + : log-emit ( char -- ) + dup (emit logc! ; + + : log-type ( addr count -- ) + 0 ?DO count log-emit LOOP drop ; + + : log-cr ( -- ) + (cr #cr logc! #lf logc! ; + +Output: alsologtofile + log-emit log-cr log-type (del noop 2drop (at? ; + + + + +\ *** Block No. 4, Hexblock 4 + +\ logopen phz 20aug23 + + : logopen ( -- ) + logfile filenamelen + 1+ fcb\nam erase + 0 logoffset ! + logfile killfile + logfile createfile + alsologtofile ; + + : logclose ( -- ) + cr display &26 logc! logflush logfile closefile ; + + + + + diff --git a/8080/CPM/cpmfiles/logapp.fth b/8080/CPM/cpmfiles/logapp.fth new file mode 100644 index 0000000..39cdc5b --- /dev/null +++ b/8080/CPM/cpmfiles/logapp.fth @@ -0,0 +1,78 @@ + + +\ Experimental code and test for text logs that can be closed +\ and reopened for appending. +\ Already integrated into log2file.fb/.fth +\ Yet to be done: A more permanent test for m+! +\ and an extension of logtest.fb/.fth to also cover the reopen feature. + + +\ Code +! ( 16b addr -- ) +\ D W mov A pop A W ) add D pop Next end-code + + Code m+! ( 16b addr -- ) + D W mov W inc W inc A pop A W ) add + CS ?[ W dec W dec W ) inc ]? + D pop Next end-code + + + + + +\ *** Block No. 2, Hexblock 2 + +\ log-type log-emit log-cr alsologtofile phz 04jan22 + context @ dos also context ! +\ vocabulary log dos also log definitions + file logfile + variable logfcb + variable logpos 0 , + + : log-type + dup logpos m+! + 2dup (type ds@ -rot logfcb @ lfputs ; + + : log-emit + 1 logpos m+! + dup (emit logfcb @ fputc ; + + : log-cr + 2 logpos m+! + (cr #cr logfcb @ fputc #lf logfcb @ fputc ; + +Output: alsologtofile + log-emit log-cr log-type (del (page (at (at? ; + + + +\ *** Block No. 3, Hexblock 3 + +\ logopen logclose phz 11jan22 + + : logopen ( -- ) + isfile push logpos dup 2+ off off + logfile make isfile@ dup freset logfcb ! + alsologtofile ; + + : logclose ( -- ) display logfcb @ fclose ; + + : logreopen ( -- ) + logfcb @ freset logpos 2@ logfcb @ fseek + alsologtofile ; + + logopen output.log + .( logtest started) cr + logpos @ cr u. cr + .( logtest interrupted) cr + logclose + logreopen + create 2v 4 allot + hex + 12345. 2v 2! + 1 2v m+! + 2v 2@ d. cr + 1ffff. 2v 2! + 1 2v m+! + 2v 2@ d. cr + .( logtest done) cr + logclose diff --git a/8080/CPM/cpmfiles/logprep.fth b/8080/CPM/cpmfiles/logprep.fth new file mode 100644 index 0000000..4e4e3d6 --- /dev/null +++ b/8080/CPM/cpmfiles/logprep.fth @@ -0,0 +1,14 @@ + + include extend2.fth +\needs drv : drv 2 ; \ showing C: if drv isn't defined + include multivid.fth + +\ : .blk|tib +\ blk @ ?dup IF ." Blk " u. ?cr exit THEN +\ incfile @ IF tib #tib @ cr type THEN ; + +\ ' .blk|tib Is .status + +\ include dos2.fth + include dos3.fth + include log2file.fth diff --git a/8080/CPM/cpmfiles/logtest.fth b/8080/CPM/cpmfiles/logtest.fth new file mode 100644 index 0000000..57a43d0 --- /dev/null +++ b/8080/CPM/cpmfiles/logtest.fth @@ -0,0 +1,38 @@ + +\ *** Block No. 0, Hexblock 0 + +\ logtest.fb phz 04jan22 + + basic tests for log2file.fb + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ loadscreen phz 22jan22 + + include log2file.fb + + logopen output.log + .( logtest done) cr + logclose + + + + + + + + + diff --git a/8080/CPM/cpmfiles/savesys.fb b/8080/CPM/cpmfiles/savesys.fb new file mode 100644 index 0000000..a07add8 --- /dev/null +++ b/8080/CPM/cpmfiles/savesys.fb @@ -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/CPM/cpmfiles/tc-base.com b/8080/CPM/cpmfiles/tc-base.com new file mode 100644 index 0000000000000000000000000000000000000000..7d6a3531597175dac057f05a25e33405048357d3 GIT binary patch literal 19456 zcmdsfd0dp&-S5MB&a=#bFfb^?uni2$unZuIxF9$iFfuTcVGxZ(>jGATk|>E9mu6{d z(`uS#-&zxGY&A*SXhK>|Qk9#yBw8^s&HiTMlEu6lFmKbuR_^!rJfObqd*6HSU-$F5 zrocJB^E>-*|DC5opQ}vh`?OT(n^N{opZr-W{t2H6U;Z>82u9(RvGXdn=bRmH6Rs5| z2dM4;_kWR8%gx zwWr0&>_s5g)wTE{?P>8c+sC-u)#7VUGs*1FXladvTG5guv-g?gZ`LZwGW(px`NH8~ zxWU!z4fw+CX=7yeSEkMgdYl1&b7Om&MP^1(Y^6D@3bTr0OK6%?%oc=6eI-m`c?8I= z5u@K??FyR!)X=mhu_(Z_W*^nFuM?v=063Y-T17D&nzl^D2>?N5om9_W4+H=R;b!sn zn(*DCc0|jISB!u+h_{Dpo}z9zbUUCYfNfyE6j^xMOT%Ct^n!S2*c%RpjuX^Qs2b)$ zk^5%)BcBnp*@S=ZXMauO-?7rZ{wFlYDE9B1 z)4|0`QLV}(-qPj@S*7SnEG(WSN}{(lR47GHYt?Lt*P=d2qC=S`5io(3OPol&S?UK? zF#tYE3xNEymjF+mw0|8#;u61a)|PLePb;cP^! zjzL%!X}35&{*^)46{qnZr^(*E^v93fW$WjHJPN5v7 z<4I&$GOwWh1N{UoJ&BdeF~tq2rebSJ%q_EExDC~{I~T3nMR%LTLb3=x>muNmMeDZe zz=g6nGZ?;&fIAkgds+vsmc`~^;+lz>Yz6<;zRe%tq~q=s}X+DT_Zfc2+K@n2V~|g{z}f4g-LU6 zw9mLblqLuYk$0G9}q^f&t*2YI8lk(F~w+RR9HoE7HWFcqOftrrBv1H1qvHq zT%$x2xj_4FKuOk0qgj>0#yV#ySQw2H#yHMJsOi=3p`Y_+VE=uH`i)`T3Xg&F>I3(Q?8dDQ)0#rSYrTtN{Oi$uric>r^JjKu!<=CQHdEpVC5+F zDa;8(8tRC`g3bS?L~Djt+KJA`uy+&@f^txa{;uy6C53&Vhyi~jMm2Ve#zi95lES`K zxCgM&faME1C{8^9h%fBYNNz|GhL*_LMx*e$X-L^*IwQVrGOJIR1ip6n-gSEpt=%zL zuio;~q3od{3}|6lkbKn()&A&_diA|l72;C^U#G@Y-$KwPg7$T(7S;pIn!8o-M<;3< z)R>ybsIpc~We=#Vyn4GDE!1&S*%kn5cB|2~FMijhzOY{#A(ia{bm}ocUpPDrIi!l^ z)ioyxG=lWL8Z-5447_g7{w{UxZv5(NRnyoxRcUSWM;iRii3YF%R(m|t5XHj!^@XF9 z#w3I2EuUIpz;IFO*bi8dfqAF)THB>T^=|wukp-T{Y5=SzV3jz zq%Lr1I%_fT)+X1?b(o8$`jO!*jwPM-5ZK>*zYebLyWNn^ergbb`D+3-sTyQ6ApYh* z>JUQ8V9yz3-^_@w+52Y$1 zklkTdv!}se{N7>+nc`G$6Nn{~T{0-OdW+piM{0mJL_-!!G0N^BgjdTHBUoM&Ravau zxB;^VpuVp$LeUT_=nBZje8xK*-r)Cvtn=?_kyH_x0maaB{q$=D^?Sx2I%>Va`+jYtqi1@4> zgL{l<&tZp+G5)WpiG-=9E{Fqj*cZl_>1r$uMjU*>7)jkKt`!B|Yuzdaq%LutWRbSX z1=3p40-2i>yHWc~^4B7fG!=LxRS@W>*V+)fg%f*hR~ljm`5EzX^A;Y*skW1Mn7sJC zIg3Un_)#^Q6L-_H6+O#uTF`UT@{WbnIfozDx>7lgzYfm2E6a;=hbbVv#CGxkmSV*c z1fI)StW?wF3ODvzJ4~CwjRe~hD;Ey~1F@S-eX#`mbF5ku_O%29Gkk!xfCUciz@ zxxGQ!K_}MqGG;GeMWZ|*Sc2Vq88&s4#t6OEm$lx{8ecaBjkLD{cFicCMxY~YZ(h~b zHR{fQ4`%bdqlU>ER7%#`+2R?+b9AnR_>AX;DaZdXD)p#2zL^ zw~F`68^t4|wrXwtIKe{p<)|3+IWmfji$azi&nk*0#77IkI)$tZwK8vfbghz*wP;-y z>Fc>`f4*qV!^fAzuf1*2n$ZWb%uu`zD;d3iZak@mePlEhv8nNLYg1WM(0gb6_ZIK# zKY4cD&(}VD{D%0o9ZSZjCyvaG?>~J#ez&#no44--dK9x;;w7zvZvA{<2xtpeg>_OL zwsA-NZjm;UjEw}OY-5~277w+wDaXJtCG44aPVZIUUr$FZ${UbKl8? zQg%E+3I$vqu+NtXU9bmB*(EFs@;zcTMdyqW?3#ctVl7f&|q;kD0`f3m4b{v%_5n`YdO^HEr+&n?jll*s7Vs8^tZ0 zq~Tb$&&2H!zdMpzB#dPrns|*?`47{I1(NVgfd#UyR=-*iOg-NXOH|rDCCyMSsBPoQjtR<1Rgj~Z7a}z}@pw~KJ+Jdtl z%eoS!Yg&EbS-sZfiDotQwX-vE3qOSuXiEG_nS~#LpMG`Zc*n7|7^~4AdOq>0OW2&a ze$W2RiMWWD634Npf#GpAzx~e`hc%3kfN>;IDQk&@{mu0k6JfykxT+$Q*dIO7cQncFZ6YdrCJ7sSCJ7t-Mbc^1UqT(fP=A)zz2<@LTOMBo z`0GjboM2*f%>%((9qvYlt+sKhtv4u%$An5Xfwh^ze zTC3QlB)KKn8YYgIh0CbYd$Ztv{H*^xaIazLR_W8UpEp9jGW_C$Ae10-DY)BRxd^2ep)7!9r2=qj< z;`Mp_P2`i9Rih4`%yuQqUIdLIwI`AjO`5dnU-NePdtK@!<9p|mFD0V%w(`nx7$ZXW zX_)=`x{l%uafznmioUj9Ynx)h@l0WdlZ`Hqr?sgyfU5wCX7Ihuws6vg?UG(P2c1dC z*3pV5*i2zA>6rL{RyV690k{kn$*h(Rs;!!} zG9}5Z=11bPjRpZ5+n}5g&1&vQ-K5tW{;8fvbye7EUM%EXCy^N`n$ZC$MB|XoDBL;y_ zV^5CZ0ar^TlKL~y!=W+6v;^KihBx@VxVR%@XbBz47Je>m3nvnq#@-zxhkY}AL_ySS zMDvx#zm7SCm}P6Y#ZUI~&=|TseUNohJ8y+?(S@U(?m6tWL{IA@I}` z74|cvtOwL!R&OP!i$zk59+-Gxu(qdhbxNYD(J0KkvlK*hu_Y;TgQgdIt-k@4=~jBN zn4uJa+DLl*2B)}7c~YX5HSFDll_|F|g3;hVNr9quh4ijwRVLl&Vh2(rg5nB~rZkEP zI4&}sbPu3Fx-aEu3b`;xQ)t9PV+J|x6;fn4NW0HWvfa%-OpzT^JV83kts)(8rj;gj zGrQ$gZ_w9LLqeg%VpfklVS3$^Xc4%FRa>N5OzkBR=3#A?n6JPUX#YuG;%j z`?WCY^M^|q!kVW~thb-Znma~F?LWCbdd7D6#Z=O2aFAa~UAHH?|AAC3B2~wJk}B2c z>SQ$Rp8_bZbfHQsZRq-yN>-M zRnp)@E;2-4JIC57^1}r(UFz5vt5o9-dSSX`K!nt>Dyu|QkV1!6ueVC2`f6zAG@(E` zosw;oh0NrbwZjKK&8c8XnaN^pZEcTT;PtG{s^|wcx!1Zd_2V&g5tq{7Gb`jZ*Rze* z7_>ZSEwNl7QnQvysAtbu_e~+YlRP$Znu(O_*+Hucu?&uD1}82|)h_2O`Tw|}diIf3 zo#6`mU2gIp7pCeybOZalRc;+-!~)5N!>p6d>d;0Ao>8qUI+o8{-Z9VCc~e&xHCcc# zh!bgG<}}{g;tSJ2yOi{_Cx{NLxHrx0MTC&~(_r@cUC?j~Q;Af;)+47HCy-q zi3*C6H4f{wZcw5*(t_plR(zkPSdu1reRcXAL(1c6m$!2kF?TSwQ~DG+C2Uo(W{v*~_z3iV)f1Tmvt>#?)~iFQcWNVN>*Qkua1?CUg+NF;pQ zW4Ht;qes+>IiqKEFPJy~rmlI*SKC(f%v*51b_|z*uuD0XHmKbd^|hq)NU#MPrM@Ix zX?KJm@aZg)ZbX{J<%U`%%U3^kI{FS15$-1Z-pNZWM-nY`_0;3WbV9IIwf3rX02krD)X@lpqwe(sMiBbAf=R#yPGINFm z3y`kkSXwoXtrNQMoY9#CFGW*M0=1-fMy$1g&E6Rb1y(ClH)?Yds;l1y^hn%OOxeX|R+I$5{P?4Hcn z=GH(!_gSFG=wOZ_e38RRgaz3XnWLJ6rCRv2MZYfHI+g{p6ZE-)Y;UHDyh0rXF88J# z%M7tInX+cBhxexCW`)={nFe@ozHlh)15eDd-ERJEW*ir?$b6&g$ju}%mI2XE=ZzEs zVtW^J;@}|Ou(+$k*1fE2bxqq@0Wwx@{e5kqXs91cj-`HB8QO z&88?)Zq|!gEbDPId4AWhJF{YN5JSo}!_W@_4YS9xM28=Abj8;tE+NVsQud~4ak*vP zJ+_4%ogK>&RHQD?Wx1)xlFS0>Kvu05e56Zy-SlD>txWI#LN+Mv5eT{1p2ds4-=j15 z&=@j&l841Nq_tJS-S;SGi%Bvico#3|S=_yh z>AL&YKDvLU?a1{^vB9sUMpbK!-ty9Wn{4|x+19*#+{w^RL&vsg@}**h06ko7y6e&m=Vf$(EG>uYNVKT6Vngg#%3WFZ96~I_bwR~?U16`kObdr*#++gYl-m-h)te(1 zxZHS7us7`jlAEgrlQ5QH{%R}Kr?_2L6LvO`PN z_gcd_J@yXMTsUjfoIUmrOGX^@c;RO`6f@bvAH`pNv?p>lIJ9YW7Z#isFKiT7rfd}@ zu@TIxOW8wa3tCj+3apL&CFiw~j<1`dIphtuu|)f8+9EXn_o4=z$@1+6XC&e)1;N=lgZl5IcYm1%uJ`z$ua&fI|kt4)~2=Gi3#gDAGpX)l6LJ&SeOWeo!E z+>98qD)iWO;_0E8lbOt05EJ}a4)wi|yBRV5T=361=Q<*ULFLC2MHU}ri~(LQW;5! zGYDIfp`;3n^GM?~LXy#yUdNW^;hDxrm!3S*3(;acDxp*r>Gp5w0m(khGl%^$PxiM^ zAgetseGWU6r`ACn=z*{6NC+-2_8x&f=o=df?JTA&g6 zW~8(J_BXN={WubD5GaJ3PU#uXbv_7S2nIA8};&MNhw)dbVgF z??_7i{*L_qev&i5AJBw!>#W@3ceY5lD zvxt3F1TW;&=#+#%bsGK*PFw2+76f_ABs^nKG^X7Li?;)i( zpFNVV40qp~_A89{ZoU{UgA4elDmwl;7&62UL4o{h3W#JI#|Z-nbezIZIEOF-u*%4^ zeG=`PmGk-8#zY8GdFArOJsq}_`HJ!Vp=z!3kTUdxB?t@b)WQM_*ys7G50ZEmPM7?n z0_j7gTA{n6ndcToqVfEi@1>Y>pXoV-ARmxZXY=e zN{lUJkpg4@aJ{|ODftC5*>4>z$)Px~8_oBalK)J>@d8~*bg+Df>~QN8N)1c3roUpK z4mQo9=oC3^ks~o(cZ8k-e6~X#8LPul?jY0^4rzFh4u>C*PWB^*+#2!@$5n1UpNB(I z5)_hro$O(UiC&mFy}=fzJ`${g!s<@;ydzF)7zQG(gH!oyf$scXz>R%9bikpXKqoum z7^U6P$PhX<%|!S{oXcG7au6p=C)UZnb4Yao&C>Y5VJsB*B34u=1^i9^2$<#{i&%A` zREOLse5{YZT*Rgq#%ey~$WFtBh&|z|x5+X28OnUb+G6rwk;8?9oLXounwe--s zA~v(ohzzCg>H)lkG5Oo@m>}C&Dp0oz`8q*Rc^eE<6=XsAO{$Z1uoIKe6g1qU+JdfZ zmT)=?={Jd?LEIRT*H?-cu$}xHY!FWvbO)7+nbvg(9nVL+@^p$GtUQ`RZq!B?V)}`- z7b1q0q2B4}Dsw$UOG`DZBkD952SLysNz-EOaR06-A{k&Mxf{PT=Dv%n*r;4ea zS`HK|4!FSeT@#C*Dkhw0u{?r8PQs94iP^&E!xu2zu)Mpc zV*x~Jf2tnBx!MPyu2PAlaS=Hx)QhGbQu0x1n^wY!DQRWYsQcbM+6i|2C*QkK z`~|}cqZl$9yV(2^(LD>jDheA)HjJmUeZ#q_TvwSJw1jRKd!z)3k|4!5-*J*E-CnZ2 zgalR>d$~lc^+0iKaDJM*QO)6`sVUe{AU$EqP_*zuJ3pm~-bNhLQudb;MSmcQQ}-n-aE^l{tB2R>=2F2|7=5ig>l~O^Lje`J6oDss~tI z%J7)gg>J^BtlcTPBDLR?#4Tl=PCN~4>$P?{$p&4@Zgh&CAmY$nPI74fWsL(@t?@Re ztUY19vc!SmB|hU68-24Lb7Foe~i4pm1U6Uc*Kt-*$`d;=#?;8PW^su|*YyKP&w-y$#lY zWrN+s$UPYEoLwsL8`y?YPNRNWT9h0^HdA6;OnfaF9HaJMD2;hw1WXo{?u?%OHqkg@ z&YXp9Rnu2dE@VHKmorv?m31Tgs1)y+wH;0=i@C0}@6yN+-X@HFR(pne%OCbPm96aCVR2G`GkMgRoo`?nf zA7y6iiD5Jiq5tqZWzl{8>rcMwZ93bxyR5%I+FyKHpI&>ix03z5OoUo}I6b{Oy?TH8 z=PN-clG`6_aTS*r#R&arc>mu2s=M(>X8Atk(GVo(7z7-<4}IH90bsu-D^Fde6L*K ztJuGlOAg`>@-=oTh2=+KI1>D;av35LE!6Nb8VIP4<%Ha8U7Yu~@@(UGLy2PrK7MR; z-6h-csbl|oEA4+Z%NQ#;NI*bVjXhJo7{xc92^CaoL?wbqF^ zNROR-ks>GAk9A0GT9E2W(8l@zW9iZZ-YYQSBEjJ%l}qaF4d)p|^UrBY@D}E%P;qMR zAmRagoGF37m8*@PH41zUi&VhpKyGcodaJO8Ev=w$1IqALf@q*afy!q~%8g{zY0fqd z1P1;f!hmbo&nm<^4{p94{eE2`fd@&SZAMCE)Qvd9HEdUf8VvcG$>E`H3615CR}lPQ zg~1aDwjiFXH<(5mKCa;2CKo8ftXlOUzOCR`&oqK$H)?~%jw6VMlS7cTY)ysY4bPz1 zFi9#(v94tqoy5~`Z~>OjK%l!+RUe1mCm92VXu_<6G; znv;S+-MpK+dTgB(NTkSJXZKCZ7G_T!N8!G;%rkD3wtnYTQ*7b)%W?eKiZ9VWb-}!4 z1wFO}UEM1>DCkFHIcY3}r?j0=CU6}q8^;}RfAlxultax})@}1HUJl)kKP#@c`Gd9< zH{Ec9=00WH=(YHr6?yRi>4R~bHAkomnbWOeyOfYW$=GR}j5wDtt_tRnQAiqRfMI14 za>r>_v%EnG8YvolrRR2xHpp+PAeUVCDAu!2$El%UOC-?h_3ceNi&)nkAy{;-+=@RNScUnJzF(iDsAy!iyNkt^vlT<;Zj-_-_kMJmVe*)r*q*lh2|~lSRwEp z_Uw3rtEI))gyc^6;q;yLJL}WSdq|qqG$UF(V0E${c7D9nK*7TSYYA%q7%zGCS}|(x zj#o7eh;LvhLrKaE5gRS^N415i0hkhX@~|mEr!4X(#>EnyQQ`}~2duGzyHXH&Q>Ek$ zBbn^3WFlW!sgB^dD@BptSZTN%y>?f|iu|@p*tzh)yzWZ7$nUL`iLQO95%0H--wN+^398U+$`4^Rnu4~GP zRuYNEIlokC)PZzR1W(f8<_Sn^yS&a8-!%kH);Wpu;t7VfFdm7IG>jf;@Jul3`MeS4 z8#B_{`?Ha8%(QxmZ<}Cn z;4PBN+IHNc^P)?d>T9m*vzhiaxvW2z<^KO{8 zU~$iCaEioJE7dDQbvO=A5V*`gnjkso^l6>jG5nQq&0i`<9zT2l=dG)fSlM`mdkOtR zaC%qex(OEPKqZ;tGS8@z9F&Wu;kqiHn?S!8Pe2@fp~i^a!(sI70_i^wf1vU!g~mI~ z$WD`aSCvLWPK}`h+LMU?o}KAKki4oY`SS@|#dG5XuJGrpq*DDfH!GwVMp0zL>j&XQ z&WO)ebZEeM07pdI8F3`>rSNa6kDsWPLXhiI z;O#VyOQon89=jAdH&wo@P;5};Z4*T(bTZS;>Xb*IN@PUc=+#RyL6S!&Y?C)DPZ>5K zB&hQB6L~49nNIITT*k}Fn%o~wgtt;fzo+77{zNM27nML8>b{|4S;s=f7)upRL@s<8 zNjY739GpNSP-Ogix4;ej>4{Rdp0XyFaBb!6%1*medoV?A@MQ8lQsAgkW!g48lij6! zn@CP07wCCsS7jIEBkfd`XICaDFKXe)0?0|~fEPaGiyDxi*i=bADuL-8NrFOgMDiUC z+&GD65ASa~Zk*l>v`a~oC?F^NKmPZBzXFmFMYL-LyEdz}Br_jS?v^M>Ytgnpb8>-1 zF1UrolT*wky&*i zpTbCAX+7fj*~ti=l08CH+&YD*l>!Qse3tQ@$Qkh~rK^(k`c=Y2;G=l=6ghi%NmuL# zYA{Wqm$?{jVQPnIqj;)vjcGT2NAPw9Q49TP%Wg4g(sz@0i!VYB(S|58xK;dS@^GI0 z_fu$~y;Fwyp9C*~;`y(q7`1TPRcArFvS3#_lTnb2mP-b}DeOC*8>$fm3sCT|!!cAv zkYM$2oSitYty+M2jCdJK;Pa{tnlz-BIeJp9K$G0`+EPC};_{wq3b_kBf!|UsIdojI zaeJx*2_u(7$4|KW@&A6x2pv(BNk!X6BwFWY6^vhzL~tM2w%+c9o1^79+U%pjD!n+AiP?F`16XM?i+6CSV*+; zbgmwtEkM{T+c+H($cR_Q?yl|y*H5+uq-v0hS(O$+01>>7tiQ>&p(;{{FunEYGzEcU z(Q3QthK2JGgi(xUK;qmtbt1WI(~_ff^y@T|)1Oi%@rtQj*I6BoyeeH~B=O@@5g*dX zuEVhkmz%^tohrjV(h@`Gr*=5*o%HTh0)IP|>nf_lQ6SwrsRwsB!UZ|JN)B4-kOx7{ z^mH(Zn`%VlHuR^Ix8va^@q)dEj(rk>;gn}9kPc2gFy-LXC7F{rO=0G>HQI|Toop#> zcL02#BOIKXQbQ;!Y7AObNyq7Mke(#?gEgGe8hSF*JuQcs}+*PqS7LZ=^2P1GdI<0 zmRAchfOtw<3)zgrNYdLJwRT7+ORbrEYjaV`8LQDhDgO~tTVqlw4j=OM>$J)OV-S_LBL7 zwYs^4kWhj2Ii8+s_9!C5mDKvDTIQO3yjBpB`G>X4jbaRnpVcxCiVVdIwakm6h~lMM zHXTKSFq#{tsl@mC;ZxdteGQ52EX*&Aqss`wXt`>|x@Aub8pD&P@ltqnBhROEARo8m zX{oN++p0? zv{*dh&<40~nlN1b?+1W4p#6*CuTG;3b~w@+!T@2R`mJfga2+Frhtd9vKjLMW>@tF# zCYDbu*OoBGB@9>fCER-JWz6A1f{6-TxJRoqHMUZ&Ay*yG?jLqVQlBtw!o$N3(;9pZ z(8Za0mn*h8*c|pD)uJUu9(3L7BCGOW0*3dxD4#?@%{N@a8!q;S3kCTNm->dw_=YP^ zRDa`&aZ#W|R0mx#aH$29{_cu_Qyzno?2hr$2d1KGa>w99R1qbsJI1f$<+_=_Ku0Wf z$F%8)liaKgK*IE(J*1;HyG4I!7g0a`(UWSGw8p=*yzlxiKp$a9u0HC< zm&c(Uumn}rBQ^vgJKQ&O)$Czj{|@&Bu4a0e52cG-b$G;Zz_Y`xaJ2%(Fp3FWor zu*03g)dnhtcet~-+T!6MPXoZ8b9Ih~&-66Z?{J^x>Jp&%FvTIR-i%`NwL9En!__A}qNmBV!(GPJr#)gz1kft3_7W7uTCVQ%;A0b-?OU$C zf!QKdKFQU0Fj^?M!~HQ=Pf^jg!~Gdo&tu@G9qzwz^*fK~bz$HF7};LY<@N4y-^$el zDth*~f6P^@S8Qo@?{VM5)jSm4C_c>9av(Ij_PC$m>J+ayGmPSIxLW5GgH-%ISFiD6 zX`wytKXA3(%fV1HkGdIG7kNd0bNHwmr@n%UfQnpQ@5Lg#N8JXl-i4wEP*`L4d&N*N zbkx0%tDC)?yz`^(SGl^wD>tZ$jeO>Q6WjMPfAeSV z_qlqKw&efJ{Tf&Q9Yqg{N4fep+8v5-b5-bG64OPHzfbboX)f2PigQd(pk0t3UCv=_noM>H`GyTy!7D{sBbkJ?tL9Q1GJr z6Rti_Mc+mD7hL@l+A-1~R}Z7qbkY5tq`rkUmQNk9z9&fPM_3rXhaRvVN97A2^MJdk z_>B)AP7hf3qsZ#$i|GODVU$PJu@LzG6BJYH@CEjObr8i|VAKHnJCw`n=wp4-hw2Yt zp-JkLI($4gLj&Z+YaXG_gOVCR%M5(MqA{js;OMLT#C%BBn|X*WptWU=jwLZneRMU^f{$ zWnroX58DqY_obY2 z(c|%>DfEu(XbQO#^eUOsio-UB{?1JQ3`tRA8l>T2PPvQ?G`1l48w@l3&EP{#C$_l+ zy*8}ZZ=I&8zN>!KY7j}#8zQOS_cP;l4H6z^HsP@UDSP)=!-%3|#wQyLgye5_1+FB= z9%~>4$&9ZxNO=AnY<{6ZV8)XTGF9s8UT9#<_*H`xp3y>0z`N8SQ-zxF|Nau|=XlW8 z_(FrqjH!NE*Sjw?7@0B8PtU0XzB;Hh4BH}L^f9W629^C8i!+u5Me!t|P93+t^5(q%FX^3wEPAN+=74P*AB80Ce z7aGToINzf2EO7K(#&+}^P6d9Y=Oy5SzJzK{z8A zPbYNRDKoMCGFFxR%js3}{OQ!AN?v=p+@?(RAJd`u-f7NsJbBP^7dozNtet)(Lvlci zc_nF?kS%-__R``{P$(E>rU)7N@;Q7eE`UH|2xJ<@r9l7xn0`job1dW(=kO0u*Yhk_ z>SlF#3ff4Oyb8}D@KqQP&1#ySojHSwo{`BF2&q82cKS}NdnZa=&UWpLw#nP%c{suU zDpNyQoGtt*1MLz5$ao3+8_C+xNS*koRL|U8i?g5y5+k{rFSXna-fTAxr@YQKj3m9j zZJ@N5AeaJLIG|-#i^k5^Hwfe%G02Z;FK!!0hM_`d!% zQr0w@p(_v@@i^)Kz^N23!-eX}0b#gqLml@1Lst(^Z}U{|PJr B=<)yn literal 0 HcmV?d00001 diff --git a/8080/CPM/cpmfiles/test-blk.fth b/8080/CPM/cpmfiles/test-blk.fth new file mode 100644 index 0000000..0171163 --- /dev/null +++ b/8080/CPM/cpmfiles/test-blk.fth @@ -0,0 +1,26 @@ + +include log2file.fb +' noop Is .status +logopen + +include ans-shim.fth +: \vf [compile] \ ; immediate + +include prelim.fth +include tester.fth +\ 1 verbose ! +include core.fr +include coreplus.fth + +include util.fth +include errorrep.fth + +include coreext.fth +include doubltst.fth + +include block.fth + +REPORT-ERRORS + +logclose + diff --git a/8080/CPM/cpmfiles/test-std.fth b/8080/CPM/cpmfiles/test-std.fth new file mode 100644 index 0000000..dd1818a --- /dev/null +++ b/8080/CPM/cpmfiles/test-std.fth @@ -0,0 +1,29 @@ + +\ : .blk|tib +\ blk @ ?dup IF ." Blk " u. ?cr exit THEN +\ incfile @ IF tib #tib @ cr type THEN ; + +include log2file.fb +logopen + +include ans-shim.fth +: \vf [compile] \ ; immediate + +include prelim.fth +include tester.fth +\ 1 verbose ! +include core.fr +include coreplus.fth + +include util.fth +include errorrep.fth + +include coreext.fth + +\ ' .blk|tib Is .status + +include doubltst.fth + +REPORT-ERRORS + +logclose diff --git a/8080/CPM/cpmfiles/testprep.fth b/8080/CPM/cpmfiles/testprep.fth new file mode 100644 index 0000000..d438799 --- /dev/null +++ b/8080/CPM/cpmfiles/testprep.fth @@ -0,0 +1,38 @@ + +\ *** Block No. 0, Hexblock 0 + +\ include file to bundle what test-*.fth need phz 30jan22 +\ on top of kernel.com + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ loadscreen to prepare kernel.com for test-*.fth phz 30jan22 + + include extend.fb + include multi.vid + include dos.fb + include include.fb + include log2file.fb + + + + + + + + + diff --git a/8080/CPM/cpmfiles/util.fth b/8080/CPM/cpmfiles/util.fth new file mode 100644 index 0000000..b224c79 --- /dev/null +++ b/8080/CPM/cpmfiles/util.fth @@ -0,0 +1,143 @@ +( The ANS/Forth 2012 test suite is being modified so that the test programs ) +( for the optional word sets only use standard words from the Core word set. ) +( This file, which is included *after* the Core test programs, contains ) +( various definitions for use by the optional word set test programs to ) +( remove any dependencies between word sets. ) + +DECIMAL + +( First a definition to see if a word is already defined. Note that ) +( [DEFINED] [IF] [ELSE] and [THEN] are in the optional Programming Tools ) +( word set. ) + +VARIABLE (\?) 0 (\?) ! ( Flag: Word defined = 0 | word undefined = -1 ) + +( [?DEF] followed by [?IF] cannot be used again until after [THEN] ) +: [?DEF] ( "name" -- ) + BL WORD FIND SWAP DROP 0= (\?) ! +; + +\ Test [?DEF] +T{ 0 (\?) ! [?DEF] ?DEFTEST1 (\?) @ -> -1 }T +: ?DEFTEST1 1 ; +T{ -1 (\?) ! [?DEF] ?DEFTEST1 (\?) @ -> 0 }T + +: [?UNDEF] [?DEF] (\?) @ 0= (\?) ! ; + +\ Equivalents of [IF] [ELSE] [THEN], these must not be nested +: [?IF] ( f -- ) (\?) ! ; IMMEDIATE +: [?ELSE] ( -- ) (\?) @ 0= (\?) ! ; IMMEDIATE +: [?THEN] ( -- ) 0 (\?) ! ; IMMEDIATE + +( A conditional comment and \ will be defined. Note that these definitions ) +( are inadequate for use in Forth blocks. If needed in the blocks test ) +( program they will need to be modified here or redefined there ) + +( \? is a conditional comment ) +: \? ( "..." -- ) (\?) @ IF EXIT THEN SOURCE >IN ! DROP ; IMMEDIATE + +\ Test \? +T{ [?DEF] ?DEFTEST1 \? : ?DEFTEST1 2 ; \ Should not be redefined + ?DEFTEST1 -> 1 }T +T{ [?DEF] ?DEFTEST2 \? : ?DEFTEST1 2 ; \ Should be redefined + ?DEFTEST1 -> 2 }T + +[?DEF] TRUE \? -1 CONSTANT TRUE +[?DEF] FALSE \? 0 CONSTANT FALSE +[?DEF] NIP \? : NIP SWAP DROP ; +[?DEF] TUCK \? : TUCK SWAP OVER ; + +[?DEF] PARSE +\? : BUMP ( caddr u n -- caddr+n u-n ) +\? TUCK - >R CHARS + R> +\? ; + +\? : PARSE ( ch "ccc" -- caddr u ) +\? >R SOURCE >IN @ BUMP +\? OVER R> SWAP >R >R ( -- start u1 ) ( R: -- start ch ) +\? BEGIN +\? DUP +\? WHILE +\? OVER C@ R@ = 0= +\? WHILE +\? 1 BUMP +\? REPEAT +\? 1- ( end u2 ) \ delimiter found +\? THEN +\? SOURCE NIP SWAP - >IN ! ( -- end ) +\? R> DROP R> ( -- end start ) +\? TUCK - 1 CHARS / ( -- start u ) +\? ; + +[?DEF] .( \? : .( [CHAR] ) PARSE TYPE ; IMMEDIATE + +\ S= to compare (case sensitive) two strings to avoid use of COMPARE from +\ the String word set. It is defined in core.fr and conditionally defined +\ here if core.fr has not been included by the user + +[?DEF] S= +\? : S= ( caddr1 u1 caddr2 u2 -- f ) \ f = TRUE if strings are equal +\? ROT OVER = 0= IF DROP 2DROP FALSE EXIT THEN +\? DUP 0= IF DROP 2DROP TRUE EXIT THEN +\? 0 DO +\? OVER C@ OVER C@ = 0= IF 2DROP FALSE UNLOOP EXIT THEN +\? CHAR+ SWAP CHAR+ +\? LOOP 2DROP TRUE +\? ; + +\ Buffer for strings in interpretive mode since S" only valid in compilation +\ mode when File-Access word set is defined + +64 CONSTANT SBUF-SIZE +CREATE SBUF1 SBUF-SIZE CHARS ALLOT +CREATE SBUF2 SBUF-SIZE CHARS ALLOT + +\ ($") saves a counted string at (caddr) +: ($") ( caddr "ccc" -- caddr' u ) + [CHAR] " PARSE ROT 2DUP C! ( -- ca2 u2 ca) + CHAR+ SWAP 2DUP 2>R CHARS MOVE ( -- ) ( R: -- ca' u2 ) + 2R> +; + +: $" ( "ccc" -- caddr u ) SBUF1 ($") ; +: $2" ( "ccc" -- caddr u ) SBUF2 ($") ; +: $CLEAR ( caddr -- ) SBUF-SIZE BL FILL ; +: CLEAR-SBUFS ( -- ) SBUF1 $CLEAR SBUF2 $CLEAR ; + +\ More definitions in core.fr used in other test programs, conditionally +\ defined here if core.fr has not been loaded + +[?DEF] MAX-UINT \? 0 INVERT CONSTANT MAX-UINT +[?DEF] MAX-INT \? 0 INVERT 1 RSHIFT CONSTANT MAX-INT +[?DEF] MIN-INT \? 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT +[?DEF] MID-UINT \? 0 INVERT 1 RSHIFT CONSTANT MID-UINT +[?DEF] MID-UINT+1 \? 0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 + +[?DEF] 2CONSTANT \? : 2CONSTANT CREATE , , DOES> 2@ ; + +BASE @ 2 BASE ! -1 0 <# #S #> SWAP DROP CONSTANT BITS/CELL BASE ! + + +\ ------------------------------------------------------------------------------ +\ Tests + +: STR1 S" abcd" ; : STR2 S" abcde" ; +: STR3 S" abCd" ; : STR4 S" wbcd" ; +: S"" S" " ; + +T{ STR1 2DUP S= -> TRUE }T +T{ STR2 2DUP S= -> TRUE }T +T{ S"" 2DUP S= -> TRUE }T +T{ STR1 STR2 S= -> FALSE }T +T{ STR1 STR3 S= -> FALSE }T +T{ STR1 STR4 S= -> FALSE }T + +T{ CLEAR-SBUFS -> }T +T{ $" abcdefghijklm" SBUF1 COUNT S= -> TRUE }T +T{ $" nopqrstuvwxyz" SBUF2 OVER S= -> FALSE }T +T{ $2" abcdefghijklm" SBUF1 COUNT S= -> FALSE }T +T{ $2" nopqrstuvwxyz" SBUF1 COUNT S= -> TRUE }T + +\ ------------------------------------------------------------------------------ + +CR $" Test utilities loaded" TYPE CR diff --git a/8080/CPM/cpmfiles/v4th.com b/8080/CPM/cpmfiles/v4th.com index 5c9021383bd57d98ec8e2997553ba3c5fac8dd4c..af77fffe6bcec116d26dd7622bbb97ff4baf17e3 100644 GIT binary patch literal 13440 zcmd^mi+@v9w(!Y$=QM4Srlo1pM;>jHK9Z(s9eiL*nxr(-G>LhDTr0>URG?CZ78Phw zM;#oe@?%u)bsQO(_7i-J&b=TrijO)^Jq? z0ssH-*jZ}4y}xhmKu0v5>~vk-Y}t^$-EC=hU+r0T`kcb`D_rjq`@*R|GAzTe@z~B% zUw^Movib*_3P`uW%IG^T@x;LnEe8t_p*P3 zC&Mmf`A9Sx!`JV!Vl*CF5Q=!s8WqDn%CZU1F0;(AV=NnoH-%xJW7$A#ms!KGKL_NF zjzloI%Ur;)hgrVemk91M>lpS|(348WQqWV#uUV`hk*-~4Bf}~jm%=qn3~S=JL~Oo`vog#z6AeINH3F=yT;?x?_HO`c zY<@Ra7iLL!5Zl(9xr_|}xT6%u#bfi=aliqBunODOt$+XkM7W*%c58e)M_9C>eqa{7 zjr(@I^+_BCOt%B{G{OE6$HwQsk^@uFLGJ!|ARdjKLZ}^43Fc9b58fC`euU77z2g%6 zcbu4tM1l$EVc0Auv>{djpBXwh{t-t;^1SG|9-&nTJ(h!(@>1}|pg)xiUdLx9nt}30 zUWx_dATHhAd}gbCRX>6Hc-B9E37=V4!;lRxg0^)XpP3vWllSs`M>rI_3#Lx@6NKA& z$)AiaSP%|A3Rqj8y@TLAz^mr}FFpgC&uyGnSzo|e>>Eh`^E~UFe}vDRv)chDbNUkE zYtUi+Eyc87LjMiV)?2^C`R~2MzV$)6#-}`wjLQ=;WJ*@x6N`K?laM(}2-6E(AQh_> zGUrIsD)4R4zD7W%%oixoBk(BV5n&Rr>VYXifs03zOQ3z0v=<6oBotdGWG2ZZs{|nx z2?XPJ0e}wJDDW;Au>$~S&(XbZ6Zlxj-!&#=YOlGpug3*G9u0@HCWkP>{aC2y974G? z#%ZONf@igAf#DhUr-A@eAlMefFE{2l~8(>weu1#S|#NHqD+VrHnZces(lwu>s)Q{rT1_>umh z$9u^lqoNoIF7PFTzYsI^6aOMI>_JfqP|&Yo#(#NaX)E*iqE=>Ce=GAuFWJfKA{(gx zOtgy3HA}u_U%38orgSPZ{N4Vc2YL?^gg=UGQ@viw*vS%##Cq#1p+%cUiEXZTW0STW z65CSWDrNLMgZu7;H<7$C>|BX$axIpCFtikLn8(!%E!w;V#<^|>?7z=Ye)UUyGM);0 z%`-C$d$%NX_`(Tjp;diIQhDgx4<%KT*Q^5Alak8oHKXnQsibQ5nmKrTNm8|V%{;tK zNURGGajFv%8;$%<%CyehVW)Ebw#0#{eC`co}4v=8nM?`K$VrJHeRz+cs>t>{fbmzI_I)l7N$M8dkelh&=8$-`bFOWCC z@`iP0hD=x~v#EJ2<;l#61@gNo8O$dE-z=-vkFRV->Wv$*R^L zVq*vzJ7v~0?`b(xJBvFCfYw8DX6WaC?UN6V=Vmwn(Cgm>=)q$-$Qv@}nb&$2L9A*fp>klg?YMP8y1iu7-4F?eG#7zzAJ z4ff|5pzA->oUc9cTcGvl(+wFt^Sq(;}zBJHH ztl&kp)JA*k3bIrU-jH;ZC}MjQj92111ynv~syxazSUn8x`vwIZ4XVPd0}3klIs?&L z0h#LWISySBh5_~9=O*zni+YQ4pR+9xeH3uvXx1ojNNbb{HF*2)Dfc^Z_MhVHE#ogM z_LgHV7FPoG1Gh#fds6w1vmUWdBi5{muY6|uWrg$~Q&gePunUbTaTinrKUP%Vl=E;h z)Zj0aouy;k5XbOY(-;>P`nX}iDC`v-!VqT!n_HMSLVnTy8U?hb43D7>{$)*_d80h4 z$J0`0-ZX!n`@k^DYj|w!=hM0XJbzz_Gb8+@Y_n@Nt{WKKuyMuU#trF}IM~LYB17?A z!ygCDI#wBg_p~l7yu$A1!$67&NI*Gb^MuxJU%V@8O6zumHX`ihJh46p4Cg(ho5(}p zukz&9crXzSFAO3s&S4bx^Mj=G!#rUgoh6)?CUdAX^1Lh1_lghcD5^mtw#9s*cp_`s zEB*uVxK4vc@I&y`wopS(aJgpqWzfabM0>)T_E1OGG$UD+xAUHs5dBt7AlVs=WKHj@ zpO&uD{E3jWMH2{u1`~!f0 zK%(={NEc^h(8a8&LgNsyg^H*!YM4n%MnR^QSgb~9H3kYYLz1?#ceoP$ z_0pm5_ilOY)S7~!dwRDN9|baF1r*j$JifF5UBh7-G+kdHrn(!uqk;PiZdrYJ^6b>` z_lF)kwZ32|y=IPl`oz+L$#ZMrxv1yxvcspza+?bTGJr-u@2kUvaG4nvI$#_3798Sm zBSo;0uwYd*3`RWIvq*ZAD9ld^cw7$yqZ8^e?u7z8?oSF-jakzd1=KXFv>d_sqJZvK zs}<^I$9xWap<^nwY#j`8Xz8G)OxO)r6h~dCrT=zz; z;O~a0@m}pMt8F*2hbJ?4{@by~v|H_khP;XIY3pucbEbHcRwRh6&t1Y)*H6L!fPYlG zwZ71tH}Ucn_@i1L=Y8)IHu{+FX(tY9FHq3r;mncKhKaLUi2k%fEbQ}x`h248Bk|xx zAPek!(xl5QnZwv~241J*J3`@bqmIxD6TsT-x&eFM#9ZBFN^5iiL<*?9yCoMfC1D-k z8H@*eb$Sg0$x-RVld$t8I>8qXN0Y;spnnGFfKJtb)@eU~K-xkEe^|hm+9iei zj&8ZQ?CpzN-aKPj3Z^PmC_!f^=?iZyoIH^(q}k4fLLn7{MDpRn$wa287~K03=o_$4 z{4*^2K%wAV6paUdO6fYBH(9qsUpjSm>Ky!T+Sz~S6TPS2E#x+Ncj)i*eqTSCIX$5@ z*aO`trk@tV20tx?4gR+99JK!n+VFt(1*Ch+&i>6$^a5OCu-kU%Gh22>H$So9Tuxpw zpPfASEj#o#8%%fDK{aa(->_U}>63+WIO+?4a^wmgZ3ZzBO~p~A9*4u2OAOIB!QDUT zjMbdy4(LD6on6ep@mg_7mh$Af-%S# zmy!31+x64r_#ZUz5nne9*k`}n;1GKHKP>AAbr5+x` z548TZGA?}9z}q0m*A&s%sQ$Fc0O|4OlMKxpxFWW}mNgk<+rtJ79<-o~B2iFV(YKw@ z0~Qx%nOAfe-jC~iMGn#q72WG}lU}3l9v5OPE*eL`aoy4!%Gx5I6DO{H*x(?#JXF-~ zo`ujc4;A@(vLmfuKLsjY*9`R%XFp7Ks6dfr~2d?rvDt|4V12vz{9M`s5>Q5+Onoal98|{uUPT<{i*I$7>)u^NW^%C z9p%xP_6YRt0ytfy>84`IAB{i}0pbxYOi)yenZvEclJe!uBGBWk$;Q9QIYhPaCbyHc z4RS*mat@BOC(WQK$uHVX%Wno@SULm99%&Ol8}~0`NpzQo{EsEM2rU) z22p~rTY>J&opVdxfTCwAo(N&UJ--A`k4`cy^zbQ&PWpg#xJI%>9qR5520}za4D$R{ zfXuL4OJoSZ!OHqU8VvH?6uPrS@k5Ll2i5j>9V*ewL`ES_oT638XG_FR;#jk$r$EYR zm|xG8OAe4Wv>s0Z7Y|537O-av`;PX-l6zQ$;gZK;w?SWw4mHRkb*>;?2!$im8oM|x zunS`^nnE~)w@S1|%z?BGD~zJ^I)4;-ImRJ_mzwCJD~(42 z(O{w#jlyk4gM4C-?zk>)M0$peLK`d{peF1wqiQH?+GE6|=#;d_NQdt=2H*@J8^8gt z7~wQR3v#VDj2*y>OU>UHrA5AY1iThK<F)VOU2oBCJaX1 z(-I(S)sJH8wR+v{%lcNYw5(fpTY8aneJOI_iBdk&;cI)VbduCzUpUslLS6LS>8PfXK3WBm_#RzX$_fRO}Y#T)mu#hfup!A0MpmQ1MOHk;u#vcEHVkL z?a=^)F6G4J+-VZ938IjuCdeeXDK)sVnQ;g;Mynz+ON&%PIfmckl7OV8MO<53+d(^W z;4za#8Fp>f^kk{E1P`LEY(KwS!n7NTVkQ;z{Kj;f@v@K_$Xx`(erh^=9R{wL@?qAE zqRg;rvkYb#G%f;~_#~Vy9L^LL5J*X((kw6Z#Y4V!OhBJ3olU~8H;bv9B02;MFtbB6 z$TK5gc=A&N=?%*^q?cJ%ZS3pAE+ZgJ6Aet7`BWkp$B7O|H=Fn1QYJVz5;tQh@j)}h z%^@FnxF<_dR6(t0xvF6>$=w1utOOPnBx(WCu&imDWU~t^HY^*s6?gNjSqKC>=o&N9 z2j)xLnIc8|PtEK?dX4ixV`5fQCV@GN2P4Et!u1EVqmd*Oow6o9u^tWqoY4>DdG_Lk{VSF&-`KZo!zRnX;Ib8K2^-n~;eezsnKA z+$Pl!bO~W$P}&dLj*i8ud_p`?OrJ1$ijA6RL-c;NAc{4sEOxQ0=){P?rEs~{1(g% zjYyVMs2nu1)9~}ae-PYkIaKR{^V-xXD4{_Zy87?L|u=1%Y(^oRAqf#W%dR$eOhUV3k z>JTVIJQfdvPCRazF#M@P!}}^Re8b~NSD+ay2h)%IhC2u-4$iY{R`lPtesy2k(!Z{6 z(~3D7-V0`G7Fox<2&|x}SZc@M1y7qojY6$l3sq$t!LSP|eK%nlDqZ~< z`^!odFanBGIp_xj`hF$n41pY7PL@$iP%>vERT(Mlt?M7OtW2*;Z-A;KPBdNFjw7C} za0s&HZc@F(LprYex)Ld)@s_?377o zX7elWp0tdgv}}3xl#7LaoH{Q->`VH#^@E#m+V5K=H|9jCgsN-@i#6UcLN~*HWVtVv zN^~Mauoi~ZgAwj4%LtdNvRVbGJ!8?qP@}ef)1bE6;rDTfW-+40X!ddV+w1(MVLv}@ zNs!~PT6sETE{NG~sn&`Vq^tr||8OEq3_HXg0$pR}lb!Jt3HpUqz|;#$kM%iFejIW) z4Ee|24VQX%S^X{-ILxOZ)t@FQ|1>ZLYQR`()d&PEAmHM?6902L5 z=P*XZ$~Nt}V3nM)I22Mqe5nHDGaFq?i`bhj5>N$R*3!Rrql>N}+eC`1Dl4>sskaHv z8&V+{*=jqYPk_*W4MNYb0h{1JxT-7+SUonLA|X*jTxZ^A(y_{wHbh)w%R?6%@Wlh6 zMp93$P<_b0F5RQW-urE$!`BYqBjCxwM*uc~w6dlh)i0L(#P*2oTV#^`HZI|Z&kXRI z?3j&>+iB={#wI$+U4Pc}i0z;~t=j|1+C8p=_6pZ*f({vn4QnQ&{Cn_AXUo{OImt3K zg$2zkU`DtXOU5{X>jLGaR#qu8LXXT`hB2(s{>#~c$8|P4&4%OlUlJln{yQ%R?6s?1 z$+#~BpByZB&<=OUrBi0OYiVFj7cJv(ZDXF;VF$}^XWPSGvjw&_Y8Rjwgtdiz_O&E9 zeaB3K|2+mtmy?EjimnF&UZ$`AaERg`o`k9Pibw6V z2C%7$MMR@;Lfs?WRfQytRdFeVVZD_?epbZ>+z7a)dNH=Z% zZu`!n3r9PpsHrdDDhtTdH@%B|#PF&js+|PXR#)|CRHC;;gPN=zv1T1F$tbr;X$g zudPW3R2^rl@LdQuT?HO@ob z69Xlgd8QgYP8V1*dZf=+!*?FDLk?D>U&z$MS1EYcg}(hS_yx*g63qUtS_~zykhRMU z0g+N8cYry#T-Y+!@Zj7QqEb=Cs;v>)8{1PIUb75bx|X!UU2tJd?!z!rcxk-9#=iAM z@_d;*4`rYL*jXbw{n2=^ZEFoFGwKUw6WPO=b4N<2>bx~4Zmb#KTQfO{7XIACN1Sb8 z4O08U_)9gjwKs|~RkyGP>vE<$%rI;Uz6+_hd21$~sDXlVjqD7B5?!EoSxD*%!JGAO zuv#`)2K(Wora^Ey`ECfy*N9j&iBHRzS4qp3_iq@aPVe0sDK}hIb`ItupWKbWX4CdEZ5V0!F%;!+(_z?acu^~nnqB0C^e+>P*C6B|Z=)sVRcWhWan6^|o zB;~!Cd1Ua6G;`M)C=2Y*l?Cb?au6)>V&E?3M-JfwX`X~&%siBfm2x%AwjkIoKRX(0+sX18f5Lz6F1yL9` zS3Cp`l1_dIT*!WYj6)(?YCfu_Gtnfm0DSu_Gw99QP6u2e!0~2HLp2VO#%~FyUj z++(QbQ-{Gh>m+)eqO+Y!D0Vzgy1pX*;~u9(C35~#PJJ0ogzy6438y$a*IwthoT#KP zIECCKdz}vw$m>oq6$|9*DtCKofJu^8qL%L+rw%_+a|NOa7o7>Bg3p^7_RmfY>Bs@I zCgjRoCry4^;KaV1k!vXjpcG!4Pflre3W|*@A-)29*#je{fwRalhP|#<=m?WYqrA4O z79neEg>a}ll%!vI3`0L$uI6&A@73m!9CCK2kJLi#366TN*j`gEEr(iLd(CU&Bel~! z_TXB$GRlyrhU)$gY8ANR3|=|G{k82id*N#YtKw#GSPKk7fx!2@5SYp!7I;C5ZHx}~ z!y>o@68jz@=<;R}XJ0Ko(F{$)iJ^FXCfyIP{ruH+*v=)W_`1|I45j1cP*JKe(qg67 zh-uUa1Y(q9J;1RMZV+S-At>65K=coBI0hwfscAV$c-+h(4vPWr&LFg>&Z-z06#sIm z7v43{TP`gC8Q!9nl%LJK3FV3(5pk-kgPI*)jZyQ7ht!e_Obej=iFL6NS%L{(CGSWq zPDh!FVQZftDZk9+S4cXI$0^ZY){VhJnEz!>T|fYGwTnZZI-!b!yiDt~;QTNY9_3N- z@Tf4!!HS5aoSeZDIA)e#)^$TBXn|1|lu>@WfTJ)2zEE~S*$*)~%?;;@Slqa>mu8p@ zI|aAWsYEi`?V`KIs3~g-3-S8x_1~!fLp|2)_KI(n;O7LpC9F{4>7J?=NO2KMS`ML$ zJ716e*dsScPDp_lU}A$+7@J+adcZQU>9*zleVgje*CURtL7YXwBwPA=kal^+A z)L>m~;M)A)IF7oU)lj+N(Nklw0TfMFE|Ky=5C0)CyrF0TVX6IQZ=0Y8QNx^Bor-^DO`{q|e`Xu|60E zU%>2galT~R)h_tpb)O5qEnJi}J?Fw06sj98&L4$3^m8suX#WoyKfi*;ahFKGfxS%P z=Q$ETb#Yz6#qT49lADLuw)c_7LbnJvB~ZD2AE~Tx!*@oppg;LO63Q@qf)v2PdqL3z zNx9Ztg$0v>a)#}8SChKQClE{A=&mNUi+=_9N_Q2Og`mK~u6Ng8Q6_=H3fth89a#AG z(O4fvB5eD*a+Pg!^JDHA$p%6pfKbdxJJ_!)pSQhO@`x=_N#pg0+=2tx0NFW8`!2SN zqmlsS4lEbO9#)UQ<=Y|d9r$AB${W&_@^IZi?VE0A`C~4FY&>e$v6vogbUoq59UXP^ zIIFXX|>4+UBVA%->6G zl$5DkR>Q|r6TB*uAu-YH*LCX~B^w+}+~4`zMtY5#ISX0EL?gZ0e0QRegG%t(b5l!C z+)|iWf_Iw}jd}3C<CjQnq zIhmQPKS!6(ee-v!kps7im9d8EDT#8S^;xJM(! z;^iIzKCMakwtJxL)O|u=CboDO_C61f0>O%5XsefFn(OG8BW`983zKnx+$%Y$^?>XZFn3G%u>!hWbZ_}? zhZ_SAdJnwXD+AZsqfig{yDQyvO_Rer;6;LVdLie4yEU)*ZaACgz4(s{8sS?Bl!3Ga zC200pj{-8{BFQ!|1OohNxS(a&H@#ekA5Ojp#(m@!KnKyE?S?Cr{QcypzVyn`STKSK z4-V6gcs?LYs+-mRa5Mq+T-u?V?XWiUfo>m2hCw#bDXwkifu8vYv5t^Q!vsQbY!vc} zR|>=zVr^Jew!N8VQcIfQKDxt~3Ij!3n?I8-c=3{cpB*n$iTz5$h5P3^?10NR2rUc{ z;o0G@sM%&OfkNG~jeUcbRai*G%H68|jq6rgw>Hyq-+j&bgnri*ON{c5iW>fc*9GHC zS1eoS7__YD>mNvC(GTZx;apIjB0Hfsf$N)jC!|00qjJ1MEnnAf39Q}#z8!uB)>=YQ z%fQC<>q+`#wczLGzw}lYKnm2dnYx)mZXt#tXfsq1Q z|GgqU!&)PVG!?>^S_F3@^iOcYcqM(Y2rFDtV)f?qwU(N4; zOC*BbaJdsla~8hpX0S?N%~~T+E%utxKYFebIs3O4w(#Eon68qE2ZVn_ OLvASH-r@i9-+u!Kf`t13 literal 13440 zcmd^md3==B)$lXVK2MgJ$z+*4lVz4HlV!5Es6fJGWKC6M4+Jr#j35gQ%uyxf(f=(ZJGC+dnZ8q{ri1?eg4Yi zx#ymH@44rm{oXR8u4-oV<0@u!ZuOU=;uM4bO)+O3-(nbr*y znr`XuyJ2-pAQWkJURG}z=)R@OQeSmh&C*j73fHf2z1P|oO?}F+48w+kkz8O3dj-oz zlb>Ez^aaDNMPAwyWTlYT9a!WIMRLc>U2Mfo6*t>lY;)VFlO1Ny!S9{yH}K1_OIW@m z5D4Pu-K-c0`4;**rqxsp!#>Ee;hHY9%&^;7HUwV^!|r5RPq53J%CN5ha!X6t8|gBq zGweZ@Z+3;fU1mMQ{uX+okzf>hG8p#vtl;Y)jZB99luh-9LV-}LtHa~>hPuqz4EuLh zUKDUU{l1R2F0+YY6^@JI8Y;u892X8QaB^0LxqP$|C@e;RwULW|MQHyvpavJTbLD=P zbbGOFy@re10DwD+a$G35U=;@(AP7C!wr&6f03gCG+#QXfdpW|Qfr{0$;EmiJp~h!$ z7%<%q&{G8a=Nuba@LCc~L3_BnLY`0{coLy@L?xJSa=iB{U*r>ncGz1k!2igJ(T)yp z7ZU*P(uAnN!PZPon0_TYa%Y^s@X<7xo z3EGzn$dm;F1=a{Wig<@G4peVViv30#LSxJrnRlSz66A==^bhQ0>? zI$({!J7L6q060BC_qtKwgFbiLHX&Yi`GtKwCh(zv-yc&;g-zVkLIqbUy2rw1mY=T~jfmkMCFV~QMyN+VFh`V^iJ}C%wxL-xYm8}AE`G$eciVdrm z#0lYyDAXZ$%EUNjPoc=y;r;>r6eYbz)Ks)WGnZ_wS!4sDPG}D8>K)!q&o(G>pl5vu z+}b<5jRKd8+*N_l?Ff9XcldbdMZ8_ts-;z zwKv-r-E=UXI~5vVl+vleSAGwxOa? ziW_(a_uUF#BKcz2ITBmzTr2@$XemN4kFytAw0RwjbKU~j|4dMR^-Fvt6!lK4i3G!b zUlLke{xG!As&1AvHT3IoNmDzmY5?|(q^X-$(e}P5Y3ip{4!&NMG!4@#4_~7a>jXrc zYD{7S9e9igLrVA%%&v+-UT^rHt_8)Z%7zN-@yM!6}Uii0CM3rg;;5-D*5octpA~U7pGI^4FRPGb{h=zu>e6-zl)iA7uOZ`wg zMc6WkU|+|B6x=j=hn8XQ(Q<(KEP~o)0@(r(U&pHyLXlq5ir%Xt-VV=iwP1gq1G@gV zmUA_SKLlD|nW zKX7Y=vS*YZIw}zB6k^Sq_`>IA_9>+QsG{+Gj$LR>iMya0_!mX<9XSOjLk&KsL~^%r zLmb1$)NPz!=;MY3ldxSZ6^1wy*xZbiP2?}yUz32=l;JVd!GAHeHDxQ0>ajy=O_|{* zxhITU`BWZTyZCOs2Y$B{;>-v?F2`-DYgVlu99VPx;F^K%RcJYIx^P?1D9-YOX(oN>jq{{OyLEkQJ)>Bkts@N2C`9k5Cx?TJa;&GkI zRKX3wSJR?Ya)QfJhxdUlo+8@gPi^+K#MFdjRo+e6AtCyAQ$3MZZ%0i1gLa4Xt<yo~{ zw7dLX2%GOuONuo}DMo8k6^kmarCJH*Go3HXIr*!!+~W-VJ%E4HM*chP2*ds;jf=LI z|2Azre#kRC_I%nz@2wvAGyWazaVFZA^l*pM*!FS^9iEj@e60%4><3A}HgadbxQ%;I z+{BHgZ6kf-#F~AUrhzeIX*9U7rn7bB-%gL05sOs~t!httd`Qw2_6`@Kzg{x*)86%u zoLrecbbIgmtT%zoU^<0WW{oUKN7rzW22JzR#b|qVd%$y7`gJP~j-Q?y{^`&oCvQq0 z>Ry>GpBh_|K0a{+{C0L7Tzc>nS#DjrKnBq0=MP#xAzWsLg%;Sxo#}fy+(;&D#4lKt zR0bm+?CF$F5QTXmoyYYsFdEZt<6ch3gb?v>4Ydn+5%D5on%^%PKhqbdkHmxLfh@4^5mg_* zHk+|04ZL2@xA^@2YCWM9CV;h@^{eeEqjU5ZDJ{_p5GkPYZjqeCl=$_0t2gBB)f-Y7 zNRDzxpMjlUs~22;e;_h^0s1$9uGVWR(K_wocT4NZ;Jfv#n}GVjf>O}qdM@aK1MG&d zqq&91=P&ge-GTNXu>spiIJ}A5%2R82P|w>VzGj+=exTh zEi`b={xQH` z7Q;V=pEz`py+bfpn=kmX;gUnxV%V^6WQzd~;xz-qJ`WgfSI0a5iE)%*djhPfftz+aBt_^@-k-k7jVU)ddW<)&&jY@l&J6Gwhyrl(H8xV1qAYzy_bpn1J?c z(1ssq??k%SKh(eOiC%yo%dp!5hWPr20_&bwIFS@LOh?BjZni`JOoqDF4w^NQ@omdR zmM+hb{Q;K;WII`}IG-Vg1JMv_#9}y%ImC`=!CU(rx{^t5!0=J>>~uyRw-i%N#=Z>H z=gW*j&=o@Ahrqzt4uiik_#t%I#=ULW1c3yG5Zk!8yj^TJ%#h>v8Tk%ZI}GTtHyKL> zlRl6!Nle3fqY#cjc0)zzL8I3dcKdu3PbYQp7(JlzE|YQLtw!DkG5Rqh4Q(n;sYb|d z*BxhQ*gs-qD{V2=DBG?yqVLy%Dv3nD;>J51&~wCyvwUMb2;UHJWKNQ{oO!3Ciu9WF z3!I2y${az!F?~T2r99K+z=_MQG?o%ooSWHPH4C9*{F$z zjIuHd-km9WplB3nI+bbA6KgZR{+*il`{eV=`)4!H8{q35Y5&PSxrFJTfUuv^bsTsI zhp0a(QQBf^r(`1RIhv`s-0o<5)DK4iC?w!}huzAfFYFTN*BS7cNRyf+xdR-K0e}XF&wZaMRA<{O=m3~MWOoCCanvtUe@ zj*!Z0g^h$1gq)OSWQq!Vy#!5aw)DS_F?| z^Q}G)9NbtolF%(}<GQ0%N9f4MP8I3>{g)rV&~tpk3h{b8VdU`UQT4=>Cs7s zg)Tk{!9^di4%aZ|XnpPNUXPDRh*4fpoP*%`IWol0U}fDP4MzF<6dK7<+z{f0K(*a% zx8)dQBBK!IP0=Fa${ewk_{Es|3y?AzrB`tIQYlCqT901<7k5if3)r)seNVSG=XMrh zxa5y>z|p#bbf{4lsc$@-BOnxx@OVxervr9j=tMJsQsIG|<2jhZ9M8cSk7UpAxL2?u z$s+ARBem@xO32yY=%VQU94~vmWQf2%=kmBpcJVE>M^C`rRg^->T$7a<{}Z!QeXmK??kULJws4pL_WTC7%acYBovT#W@lRJKTLwwS5^p#xnYLFoB&mGom^tEM33I)l=At8$nR|s&agvjiKP713dL&nL;Fv~P zg*E9iB+~v@u0Y@@E+Uw|E*@yd$`8-b&?Q?H8k++i2wn1t$(f@H*aT7NrY1-gswg$M zvY9CrCUUHb$P{F1hLQ|l;FN%*f=sTdscF!TN7boHlwnuI)aAK<%Ep5@Z-$&%!mOEL zH>n!v`I%a2x+tVZa+ScaFQ^CSV%&)t8z#*t$_)FaDuY=Djq3nST%Jn~XA1LwQW5x2 zl^3}}K36m5kIQpsbLfAnVl=6UrGf>R*&-U{#3nF2Y0=f)14{?Gms)z(^z~tv2@qz8 z1{%$LH0%xGM7yOt^HV4XDx4b$d$AJeGeg+xbAg9jo{ORiYCX%>_##^Y8I3d(13>ISY9^ zh>>L2kDwjsh(OIKrk*gD3b;c&Mr`Fv=gqj*7iJzRk&xS-fI|Rh^r-xeEo)K#^-Gtn z>03H*n`QOj((7*^Y&Z`HyQLH68FE%Q)|AIb0%6!Fjz#N=yF&!*jN~bB&EjeXw~CQ3 zWjnIITaSXf8Gd*1m8LO+36CB}+?*$n+o(tK7$z64<=`GD531mS2m-FCdMOXezj=J1 z!w=J)Fn=z+mRFdEAB9M#)3!e8pz^(bXO{yX268yrTvi=cNFf zeI34t4`e5%;s(zUT4E|xVx;lhCB$SI^96_i@iF0K9(F?6A3P3i>?iS8Z@%CFx;^jY$Hxz;lZ62zF%^48{+fT#jAa5AD;P(J-8h=aABQ40r07@|{Y^fkeH|WT0ZNHqK$c-Cg$IW@ z43M|;(X8|d59Lonh>Oy*33?UCyt|=v^C6fS8j<7|Xi8~hm&$(w{u^1+Q*h+!Waf5F zOkG((Q?_*lqgR)bHjQrYD@f^x`u#L#0Y`?6IS%Cu8&6HxQw3=qfhtn|4AbMH(Xq&2 zoG`oAfdU!s6 z=DMgQD47ZAfSJ_gR`m~BmUs7b4?s~7Cwi%{8Aq%vC>0JDHj&~Z9?~)WD}_iI9lys4 zlJ+PVxs<^bz26`V8JHx1r~(*`Y473M_I@B#CEES6}u5xN=nS<4TC(Qqp=1WQ?%{BPp+ST=FANP5sB zKus|Z#l7=bPAf;g}bBEaopGbt+FZv_WHdMY@K5wS2$dv;nSM=%6+5D;Ig z0BKBvvmleb#v%b#;AJiSH#9iu3Wu#C#XVpiw}Pp+3XUtIJ{b8g>kkYWAoTwrc963P zr3gP@PO&kp*~U{OBx;CjP5E59yU=bUOn~D87wd6_JicmD4lU4p#2%Jz*I}>6CYHLI z;W+`G9K$ZN38WQM1I24|Zm@-HHDr>TZCuz5uLSUx>uwtxveVGz6>Xw!k@P|DbXNj`F3|A$U zta{!u0=F*a(SRK+znyLNPpcN#)>69w#UQLL^w`TuPTgl02?Vrr3)GNhX3$QBC#Jrv zr;*eKJKq}cqx?z_+h_QP?I04wEk12$=hm)KBiUvv!cDQW0?;wqsC_{6A*r z!z7Z%qzU5-=PyXK^=G>VhGQDLRM!PrD3nugO=3tG@zk`46!B}A7af;hiyQ5<25?ysi-;y+OxqJ;6#^QIXe_v~NCWLL?Itqdks>xqx@mJeObHZGCBU`7bltDLT)Cfk;H~`g zMY|>Rz_`|)BFo}u)TvVLi0)>o)ur)lV26BjB6=~u23q`^0y|TDbsdKVcuHRNg zUtqY4p)LfGA-?ihS`3E84Hq`(P1`v1q#|5OOhVZb10|VRQH&m^4J;Ww(i@B6na1pp z!D93a@d|iUf>%}O+rPpGBnL?_`}1Pa7sf(Xml*=0BgJwHn1hRjt=|>%;M^9WQc=bF zq*!RKZjQE0t1@uuE7J0}!F@Bi&caCH)sd;+4_7`Ti1QK|5OG*7~_!i$TXIdmEKEW znJK28EvAx^0cjWpjkIoKRsNDVS3C%P=SmO@qA+fbxECBGoqR92kX`&X4v9Ed{A@9u zi6)8Z;M-@JK`+K4rEmiP#~V}UmXwM#e#>x34%iLJJ?56YPWg#9;^J0F=TV zY2=hv8Q?5(jA6fa2rYgRY5c*Vlp&q3~F|GvqjA(9#TUxFinT@C)UL_$r4QPI{8LoaXQLW3|spINqHlgUm@u<9;Za_ zF5dK61xF`u=ee+!>y3!q$J1VKcdcBfsa)aa8==`{7lWgPBQ)98A zRCr3CFOl*>7yl74y={a|zpIq!W6@-V3F;3YB{?WNc`s=Bmz5AT*qy99^d**as-1jf zanSo^B{1P~CkL+XIgl9rQuRHR%69{D(K1>SW32A>GO*p@D7Gc3;4C05>s$x<%c^ldvVl+t zAQTDdKK7Nu8*OWILbi-T8n64Sgi>GwWalXDPqJ+sl>{hvV7V}OzjhN`zU}4Sg9kU4 z-jJTlODV4_`$^Tud7Tgqm^Rw=ET#ty&a10XIyYAFIP1q%<(V3cnGC6#^d<~A(niiz zX&#ydV?;%h(W$Qt%4|3@1+i7*Xk86seW}=1%g~Zx6})FAJDgjsxu$CL{OlB-c9?sL zJVRagtC9BV^{>K@r@dTcsu){KnSnW*Ys=Ocn1ANlC@E9dt$?>rqr4^_Co$3N zsvpVw6y-!{_65SOikfl_Gj7h!%^g3~+%{HFa}e&)NU_*jBf!g;u&ccW%1-TL0yBC= z4a2%?cpMi~%W9~gF9rahfqhK^^fjEl8KQ9+q;@@gyF=4z8hmerZ$HGP3Vc6M!`r=K z_q1w;#ujKqT+P#}78)-=1C(xB{T?)4g+?uOLU z{#YY8P(Lu&*e#XS9EZRW;h)!tU?QOhJ6?wl1j@BMBFEGf#s8?WDqklIwG7`-8y`Mz zIXS=f@875UfXdu8=)lSx|Ai;vWmV--%n7X-UvgT3vhqHCUY(Q~Ly&V8O_Q@Lj ziyb#W2bc$387?RQ@Pk@D;tRrU4km?AP1Bc?bc6Eop;`=V;n~Jwle4Y%n%XC72WszQ zOT~MDHZ<`zexMew92s_3tpp3wo15Ef@N!OMj@M3d2QK;EOukdWt@S`1WYCVeNVyZ^ z#}>HSG{IGuj?DE3n2TBu$X)>xQY1*Y(dD9h`;BuFs`+P#6J%INoeW%S4nRF%pR=g; zA2pM;b#+Kkqz-ZpxLcc6zYk|~V;%l~1FGSz1j<0S1SM#8WsQPS9Z9xUdAP3narRt8|L5>Uf}M0Ya>8WYUy+gb*AXg{-fWJfTHc8$Mueucw(*em&er zx45EyplE*m=hDtPyrl23VbkK5rU;pZEEc)SG zPMizMQ)DOfCa}7mcR>0>--P2GYW}Kzi)Y0E_;&cS`UZbHzP>LlEN$2bzfmAd7$C>B1oBnOMAOlqr~iN(7M85Z#!J>gwUL&d@B#E z5?Hgw4yYDStLPukHVCa)Je*e1qyMWx@X!`M;eW3|CLR#}KQQEm67C)TU;Ot!xUQ1t diff --git a/8080/CPM/cpmfiles/vf-core.fth b/8080/CPM/cpmfiles/vf-core.fth index 374117e..ba54d5d 100644 --- a/8080/CPM/cpmfiles/vf-core.fth +++ b/8080/CPM/cpmfiles/vf-core.fth @@ -895,8 +895,9 @@ Code allot ( n -- ) user' dp D lxi \ input strings 11Jun86 +$84 Constant /tib Variable #tib 0 #tib ! -Variable >tib here >tib ! $50 allot +Variable >tib here >tib ! /tib allot Variable >in 0 >in ! Variable blk 0 blk ! Variable span 0 span ! diff --git a/8080/CPM/cpmfiles/vf-file.fth b/8080/CPM/cpmfiles/vf-file.fth new file mode 100644 index 0000000..16729d6 --- /dev/null +++ b/8080/CPM/cpmfiles/vf-file.fth @@ -0,0 +1,171 @@ + +\ *** Block No. 0, Hexblock 0 + +\ include for stream sources for cp/m phz 30aug23 + +cr .( order) order cr + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ load screen phz 02sep23 + + \ onlyforth dos also forth definitions + + : idos-error? ( n -- f ) 0<> ; + : iread-seq ( dosfcb -- f ) $14 bdosa idos-error? ; + : cr+ex@ ( fcb -- cr+256*ex ) + dup &34 + c@ swap &14 + c@ $100 * + ; + : cr+ex! ( cr+256*ex fcb -- ) + >r $100 u/mod r@ &14 + c! r> &34 + c! ; + + \ 1 7 +thru + + + + + +\ *** Block No. 2, Hexblock 2 + +\ fib /fib #fib eolf? phz 09okt24 + + \ context @ dos also context ! + \ $50 constant /tib + variable tibeof tibeof off + $1a constant ctrl-z + + : eolf? ( c -- f ) + \ f=-1: not yet eol; store c and continue + \ f=0: eol but not yet eof; return line and flag continue + \ f=1: eof: return line and flag eof + tibeof off + dup #lf = IF drop 0 exit THEN + ctrl-z = IF tibeof on 1 ELSE -1 THEN ; + + + +\ *** Block No. 3, Hexblock 3 + +\ incfile incpos inc-fgetc phz 02sep23 + + variable incfile + variable increc + variable rec-offset + $80 constant dmabuf | $ff constant dmabuf-last + + : readrec ( fcb -- f ) + dup cr+ex@ increc ! + rec-offset off dmabuf dma! drive iread-seq ; + + : inc-fgetc ( -- c ) + rec-offset @ b/rec u< 0= + IF incfile @ readrec IF ctrl-z exit THEN THEN + rec-offset @ dmabuf + c@ 1 rec-offset +! ; + + +\ *** Block No. 4, Hexblock 4 + +\ freadline probe-for-fb phz 25aug23 + + : freadline ( -- eof ) + tib /tib bounds DO + inc-fgetc dup eolf? under 0< IF I c! ELSE drop THEN + 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN + LOOP /tib #tib ! + ." warning: line exteeds max " /tib . cr + ." extra chars ignored" cr + BEGIN inc-fgetc eolf? 1+ UNTIL tibeof @ ; + +| : probe-for-fb ( -- flag ) + dmabuf BEGIN dup c@ #lf = IF drop 0 exit THEN + 1+ dup dmabuf-last u> UNTIL drop 1 ; + + + +\ *** Block No. 5, Hexblock 5 + +\ save/restoretib phz 06okt22 + + $50 constant /stash + create stash[ /stash allot here constant ]stash + variable stash> stash[ stash> ! + + : savetib ( -- n ) + #tib @ >in @ - dup stash> @ + ]stash u> + abort" tib stash overflow" >r + tib >in @ + stash> @ r@ cmove + r@ stash> +! r> ; + + : restoretib ( n -- ) + dup >r negate stash> +! stash> @ tib r@ cmove + r> #tib ! >in off ; + + +\ *** Block No. 6, Hexblock 6 + +\ interpret-via-tib inner-include phz 02sep23 + + : interpret-via-tib + BEGIN freadline >r .status >in off interpret r> UNTIL ; + + : include-inner ( -- ) + increc push 0 isfile@ cr+ex! + isfile@ readrec Abort" can't read start of file" + probe-for-fb IF 1 load exit THEN + incfile push isfile@ incfile ! + savetib >r interpret-via-tib close r> restoretib ; + + + + + + +\ *** Block No. 7, Hexblock 7 + +\ include phz 02sep23 + + : include ( -- ) + rec-offset push isfile push fromfile push + use cr file? + include-inner + incfile @ + IF increc @ incfile @ cr+ex! + incfile @ readrec Abort" error re-reading after include" + THEN ; + + + + + + + +\ *** Block No. 8, Hexblock 8 + +\ \ phz 02sep23 + + : (stashquit stash[ stash> ! incfile off increc off + (quit ; + : stashrestore ['] (stashquit IS 'quit ; + ' stashrestore IS 'restart + + : \ blk @ IF >in @ negate c/l mod >in +! + ELSE #tib @ >in ! THEN ; immediate + +\ : \needs have 0=exit +\ blk @ IF >in @ negate c/l mod >in +! +\ ELSE #tib @ >in ! THEN ; + + + diff --git a/8080/CPM/cpmfiles/xinout.fb b/8080/CPM/cpmfiles/xinout.fb new file mode 100644 index 0000000..364659e --- /dev/null +++ b/8080/CPM/cpmfiles/xinout.fb @@ -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: UH 06Mar88 &80 Constant c/row &24 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 CP/M UH 18Mar88: (decode ( addr pos1 key -- addr pos2 ) 4 case? IF dup span @ < 0=exit currite 1+ exit THEN &19 case? IF dup 0=exit curleft 1- exit THEN &22 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 7 case? IF span @ 2dup < and 0=exit (del exit THEN $1B 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