├── test ├── report-errors.fs ├── target-tester.fs ├── tester.fs ├── testerrorreport.fs ├── testutilities.fs ├── testcoreplus.fs ├── testcoreext.fs ├── testcore.fs └── target.fs ├── .gitignore ├── run_tests.sh ├── run_examples.sh ├── examples ├── colorcycle.fs ├── balloon.fs └── sierp.fs ├── dictionary.py ├── README.md ├── LICENSE.txt ├── src ├── header.asm └── words.fs ├── xc.py └── acmeforth /test/report-errors.fs: -------------------------------------------------------------------------------- 1 | report-errors 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | __pycache__ 2 | *.asm 3 | *.prg 4 | *.swp 5 | -------------------------------------------------------------------------------- /run_tests.sh: -------------------------------------------------------------------------------- 1 | set -e 2 | ./acmeforth test/target-tester.fs test/target.fs 3 | acme -o target-test.prg -f cbm target-test.asm 4 | x64 target-test.prg 5 | echo "Accept text" | ./acmeforth test/tester.fs test/testutilities.fs test/testcore.fs test/testerrorreport.fs test/testcoreplus.fs test/testcoreext.fs test/report-errors.fs 6 | -------------------------------------------------------------------------------- /run_examples.sh: -------------------------------------------------------------------------------- 1 | set -e 2 | 3 | ./acmeforth examples/balloon.fs 4 | acme -o balloon.prg -f cbm balloon.asm 5 | x64 balloon.prg 6 | 7 | ./acmeforth examples/sierp.fs 8 | acme -o sierp.prg -f cbm sierp.asm 9 | x64 sierp.prg 10 | 11 | ./acmeforth examples/colorcycle.fs 12 | acme -o colorcycle.prg -f cbm colorcycle.asm 13 | x64 colorcycle.prg 14 | -------------------------------------------------------------------------------- /examples/colorcycle.fs: -------------------------------------------------------------------------------- 1 | hex 2 | 3 | : forth begin key? 0= while d020 c@ 1+ d020 c! repeat key drop ; 4 | 5 | code asm 6 | - inc $d020 7 | lda $c6 8 | beq - 9 | lda #0 10 | sta $c6 11 | rts 12 | ;code 13 | 14 | : colorcycle 15 | cr ." space=toggle asm/forth" 16 | begin asm cr ." forth" forth cr ." asm" again ; 17 | 18 | compile colorcycle 19 | -------------------------------------------------------------------------------- /dictionary.py: -------------------------------------------------------------------------------- 1 | class Dictionary: 2 | def __init__(self): 3 | self.words = {} 4 | self.xt_words = {} 5 | self.code_words = {} 6 | self.latest = None 7 | 8 | def copy(self): 9 | d = Dictionary() 10 | d.words = self.words.copy() 11 | d.xt_words = self.xt_words.copy() 12 | d.code_words = self.code_words.copy() 13 | d.latest = self.latest 14 | return d 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ACMEforth 2 | 3 | ## What? 4 | 5 | ACMEforth is a cross-compiling 16-bit Forth targeting the Commodore 64, using [ACME](https://sourceforge.net/projects/acme-crossass/) for assembling. 6 | All [Forth 2012 core words](https://forth-standard.org/standard/core) are supported, although interpreting and compiling only works on PC. 7 | 8 | ## Examples 9 | 10 | `sh run_examples.sh` 11 | 12 | ## Why? 13 | 14 | * Quick compiles 15 | * Lean output (no dictionary or unused words) 16 | * Macro support with CREATE/DOES> 17 | * Convenient text editing on PC 18 | -------------------------------------------------------------------------------- /examples/balloon.fs: -------------------------------------------------------------------------------- 1 | \ Up, up and away! 2 | \ Adapted from Commodore 64 Users Guide. 3 | 4 | create sprite 5 | 0 c, 127 c, 0 c, 1 c, 255 c, 192 c, 3 c, 255 c, 224 c, 3 c, 231 c, 224 c, 6 | 7 c, 217 c, 240 c, 7 c, 223 c, 240 c, 7 c, 217 c, 240 c, 3 c, 231 c, 224 c, 7 | 3 c, 255 c, 224 c, 3 c, 255 c, 224 c, 2 c, 255 c, 160 c, 1 c, 127 c, 64 c, 8 | 1 c, 62 c, 64 c, 0 c, 156 c, 128 c, 0 c, 156 c, 128 c, 0 c, 73 c, 0 c, 0 c, 73 c, 0 c, 9 | 0 c, 62 c, 0 c, 0 c, 62 c, 0 c, 0 c, 62 c, 0 c, 0 c, 28 c, 0 c, 10 | 11 | : vsync 12 | begin $d011 c@ $80 and 0= until 13 | begin $d011 c@ $80 and until ; 14 | 15 | : balloon page 16 | 4 $d015 c! \ enable sprite 2 17 | 13 $7fa c! \ sprite 2 data from 13th block 18 | sprite $340 63 move \ copy sprite to 13th block 19 | begin 200 0 do vsync 20 | i $d004 c! i $d005 c! \ move sprite 21 | loop again ; 22 | 23 | compile balloon 24 | -------------------------------------------------------------------------------- /examples/sierp.fs: -------------------------------------------------------------------------------- 1 | \ https://boomlin.de/software/sierp.fs 2 | hex 3 | variable x variable y 4 | 5 | : orc dup c@ rot or swap c! ; 6 | : rnd d012 c@ ; 7 | : init 8 d018 orc 20 d011 orc ; 8 | : clear 2000 dup 0 fill 400 dup 70 fill ; 9 | : calcx ( x -- offset ) fff8 and ; 10 | : calcy ( y -- offset ) dup 2/ 2/ 2/ 140 * swap 7 and + ; 11 | : store ( v x y -- ) calcy swap calcx + 2000 + orc ; 12 | : calcbit 1 swap 7 and 7 xor lshift ; 13 | : plot ( x y ) over calcbit rot rot store ; 14 | : avg ( x1 y1 x2 y2 -- x y ) rot + 2/ rot rot + 2/ swap ; 15 | 16 | decimal 17 | : p1 160 20 ; 18 | : p2 60 180 ; 19 | : p3 260 180 ; 20 | 21 | : sierp 22 | p1 y ! x ! init clear 23 | begin 24 | rnd 3 and case 25 | 0 of p1 x @ y @ avg y ! x ! endof 26 | 1 of p2 x @ y @ avg y ! x ! endof 27 | 2 of p3 x @ y @ avg y ! x ! endof 28 | endcase 29 | x @ y @ plot again ; 30 | 31 | compile sierp 32 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright 2019 Johan Kotlinski 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 8 | -------------------------------------------------------------------------------- /src/header.asm: -------------------------------------------------------------------------------- 1 | ; Compile with ACME assembler 2 | 3 | !cpu 6510 4 | 5 | * = $801 6 | 7 | !byte $b, $08, $a, 0, $9E, $32, $30, $36, $31, 0, 0, 0 ; basic header 8 | 9 | ; Parameter stack 10 | ; The x register contains the current stack depth. 11 | ; It is initially 0 and decrements when items are pushed. 12 | ; The parameter stack is placed in zeropage to save space. 13 | ; (E.g. lda $FF,x takes less space than lda $FFFF,x) 14 | ; We use a split stack that store low-byte and high-byte 15 | ; in separate ranges on the zeropage, so that popping and 16 | ; pushing gets faster (only one inx/dex operation). 17 | X_INIT = 0 18 | MSB = $73 ; high-byte stack placed in [$3b .. $72] 19 | LSB = $3b ; low-byte stack placed in [3 .. $3a] 20 | 21 | W = $8b ; rnd seed 22 | W2 = $8d ; rnd seed 23 | W3 = $9e ; tape error log 24 | 25 | OP_JMP = $4c 26 | OP_JSR = $20 27 | OP_RTS = $60 28 | OP_INX = $e8 29 | 30 | PUTCHR = $ffd2 ; put char 31 | 32 | K_RETURN = $d 33 | K_CLRSCR = $93 34 | K_SPACE = ' ' 35 | 36 | !ct pet 37 | 38 | ; -------- program start 39 | 40 | tsx 41 | stx INIT_S 42 | ldx #X_INIT 43 | jsr WORD_0 44 | BYE 45 | INIT_S = * + 1 46 | ldx #0 47 | txs 48 | rts 49 | -------------------------------------------------------------------------------- /test/target-tester.fs: -------------------------------------------------------------------------------- 1 | \ From: John Hayes S1I 2 | \ Subject: tester.fr 3 | \ Date: Mon, 27 Nov 95 13:10:09 PST 4 | 5 | \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY 6 | \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 7 | \ VERSION 1.2 8 | 9 | \ 24/11/2015 Replaced Core Ext word <> with = 0= 10 | \ 31/3/2015 Variable #ERRORS added and incremented for each error reported. 11 | \ 22/1/09 The words { and } have been changed to T{ and }T respectively to 12 | \ agree with the Forth 200X file ttester.fs. This avoids clashes with 13 | \ locals using { ... } and the FSL use of } 14 | 15 | HEX 16 | 17 | \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY 18 | \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. 19 | VARIABLE VERBOSE 20 | 0 VERBOSE ! 21 | 22 | : EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. 23 | DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ; 24 | 25 | VARIABLE #ERRORS 0 #ERRORS ! 26 | 27 | : ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY 28 | \ THE LINE THAT HAD THE ERROR. 29 | CR TYPE \ SOURCE TYPE \ DISPLAY LINE CORRESPONDING TO ERROR 30 | EMPTY-STACK \ THROW AWAY EVERY THING ELSE 31 | #ERRORS @ 1 + #ERRORS ! 32 | bye \ *** Uncomment this line to QUIT on an error 33 | ; 34 | 35 | VARIABLE ACTUAL-DEPTH \ STACK RECORD 36 | CREATE ACTUAL-RESULTS 20 CELLS ALLOT 37 | 38 | : T{ \ ( -- ) SYNTACTIC SUGAR. 39 | ; 40 | 41 | : -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. 42 | DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH 43 | ?DUP IF \ IF THERE IS SOMETHING ON STACK 44 | 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM 45 | THEN ; 46 | 47 | : }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED 48 | \ (ACTUAL) CONTENTS. 49 | DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH 50 | DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK 51 | 0 DO \ FOR EACH STACK ITEM 52 | ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED 53 | = 0= IF S" incorrect result: " ERROR LEAVE THEN 54 | LOOP 55 | THEN 56 | ELSE \ DEPTH MISMATCH 57 | S" wrong number of results: " ERROR 58 | THEN ; 59 | -------------------------------------------------------------------------------- /test/tester.fs: -------------------------------------------------------------------------------- 1 | \ From: John Hayes S1I 2 | \ Subject: tester.fr 3 | \ Date: Mon, 27 Nov 95 13:10:09 PST 4 | 5 | \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY 6 | \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 7 | \ VERSION 1.2 8 | 9 | \ 24/11/2015 Replaced Core Ext word <> with = 0= 10 | \ 31/3/2015 Variable #ERRORS added and incremented for each error reported. 11 | \ 22/1/09 The words { and } have been changed to T{ and }T respectively to 12 | \ agree with the Forth 200X file ttester.fs. This avoids clashes with 13 | \ locals using { ... } and the FSL use of } 14 | 15 | HEX 16 | 17 | \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY 18 | \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. 19 | VARIABLE VERBOSE 20 | 1 VERBOSE ! 21 | 22 | : EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. 23 | DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ; 24 | 25 | VARIABLE #ERRORS 0 #ERRORS ! 26 | 27 | : ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY 28 | \ THE LINE THAT HAD THE ERROR. 29 | CR TYPE SOURCE TYPE \ DISPLAY LINE CORRESPONDING TO ERROR 30 | EMPTY-STACK \ THROW AWAY EVERY THING ELSE 31 | #ERRORS @ 1 + #ERRORS ! 32 | \ QUIT \ *** Uncomment this line to QUIT on an error 33 | ; 34 | 35 | VARIABLE ACTUAL-DEPTH \ STACK RECORD 36 | CREATE ACTUAL-RESULTS 20 CELLS ALLOT 37 | 38 | : T{ \ ( -- ) SYNTACTIC SUGAR. 39 | ; 40 | 41 | : -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. 42 | DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH 43 | ?DUP IF \ IF THERE IS SOMETHING ON STACK 44 | 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM 45 | THEN ; 46 | 47 | : }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED 48 | \ (ACTUAL) CONTENTS. 49 | DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH 50 | DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK 51 | 0 DO \ FOR EACH STACK ITEM 52 | ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED 53 | = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN 54 | LOOP 55 | THEN 56 | ELSE \ DEPTH MISMATCH 57 | S" WRONG NUMBER OF RESULTS: " ERROR 58 | THEN ; 59 | 60 | : TESTING \ ( -- ) TALKING COMMENT. 61 | SOURCE VERBOSE @ 62 | IF DUP >R TYPE CR R> >IN ! 63 | ELSE >IN ! DROP [CHAR] * EMIT 64 | THEN ; IMMEDIATE 65 | 66 | 67 | -------------------------------------------------------------------------------- /test/testerrorreport.fs: -------------------------------------------------------------------------------- 1 | \ To collect and report on the number of errors resulting from running the 2 | \ ANS Forth and Forth 2012 test programs 3 | 4 | \ This program was written by Gerry Jackson in 2015, and is in the public 5 | \ domain - it can be distributed and/or modified in any way but please 6 | \ retain this notice. 7 | 8 | \ This program is distributed in the hope that it will be useful, 9 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 | 12 | \ ------------------------------------------------------------------------------ 13 | \ This file is INCLUDED after Core tests are complete and only uses Core words 14 | \ already tested. The purpose of this file is to count errors in test results 15 | \ and present them as a summary at the end of the tests. 16 | 17 | DECIMAL 18 | 19 | VARIABLE TOTAL-ERRORS 20 | 21 | : ERROR-COUNT ( "name" n1 -- n2 ) \ n2 = n1 + 1cell 22 | CREATE DUP , CELL+ 23 | DOES> ( -- offset ) @ \ offset in address units 24 | ; 25 | 26 | 0 \ Offset into ERRORS[] array 27 | ERROR-COUNT CORE-ERRORS ERROR-COUNT CORE-EXT-ERRORS 28 | ERROR-COUNT DOUBLE-ERRORS ERROR-COUNT EXCEPTION-ERRORS 29 | ERROR-COUNT FACILITY-ERRORS ERROR-COUNT FILE-ERRORS 30 | ERROR-COUNT LOCALS-ERRORS ERROR-COUNT MEMORY-ERRORS 31 | ERROR-COUNT SEARCHORDER-ERRORS ERROR-COUNT STRING-ERRORS 32 | ERROR-COUNT TOOLS-ERRORS ERROR-COUNT BLOCK-ERRORS 33 | CREATE ERRORS[] DUP ALLOT CONSTANT #ERROR-COUNTS 34 | 35 | \ SET-ERROR-COUNT called at the end of each test file with its own offset into 36 | \ the ERRORS[] array. #ERRORS is in files tester.fr and ttester.fs 37 | 38 | : SET-ERROR-COUNT ( offset -- ) 39 | #ERRORS @ SWAP ERRORS[] + ! 40 | #ERRORS @ TOTAL-ERRORS +! 41 | 0 #ERRORS ! 42 | ; 43 | 44 | : INIT-ERRORS ( -- ) 45 | ERRORS[] #ERROR-COUNTS OVER + SWAP DO -1 I ! 1 CELLS +LOOP 46 | 0 TOTAL-ERRORS ! 47 | CORE-ERRORS SET-ERROR-COUNT 48 | ; 49 | 50 | INIT-ERRORS 51 | 52 | \ Report summary of errors 53 | 54 | 25 CONSTANT MARGIN 55 | 56 | : SHOW-ERROR-LINE ( n caddr u -- ) 57 | CR SWAP OVER TYPE MARGIN - ABS >R 58 | DUP -1 = IF DROP R> 1- SPACES ." -" ELSE 59 | R> .R THEN 60 | ; 61 | 62 | : SHOW-ERROR-COUNT ( caddr u offset -- ) 63 | ERRORS[] + @ ROT ROT SHOW-ERROR-LINE 64 | ; 65 | 66 | : HLINE ( -- ) CR ." ---------------------------" ; 67 | 68 | : REPORT-ERRORS 69 | HLINE 70 | CR 8 SPACES ." Error Report" 71 | CR ." Word Set" 13 SPACES ." Errors" 72 | HLINE 73 | S" Core" CORE-ERRORS SHOW-ERROR-COUNT 74 | S" Core extension" CORE-EXT-ERRORS SHOW-ERROR-COUNT 75 | S" Block" BLOCK-ERRORS SHOW-ERROR-COUNT 76 | S" Double number" DOUBLE-ERRORS SHOW-ERROR-COUNT 77 | S" Exception" EXCEPTION-ERRORS SHOW-ERROR-COUNT 78 | S" Facility" FACILITY-ERRORS SHOW-ERROR-COUNT 79 | S" File-access" FILE-ERRORS SHOW-ERROR-COUNT 80 | S" Locals" LOCALS-ERRORS SHOW-ERROR-COUNT 81 | S" Memory-allocation" MEMORY-ERRORS SHOW-ERROR-COUNT 82 | S" Programming-tools" TOOLS-ERRORS SHOW-ERROR-COUNT 83 | S" Search-order" SEARCHORDER-ERRORS SHOW-ERROR-COUNT 84 | S" String" STRING-ERRORS SHOW-ERROR-COUNT 85 | HLINE 86 | TOTAL-ERRORS @ S" Total" SHOW-ERROR-LINE 87 | HLINE CR CR 88 | ; 89 | 90 | -------------------------------------------------------------------------------- /test/testutilities.fs: -------------------------------------------------------------------------------- 1 | ( The ANS/Forth 2012 test suite is being modified so that the test programs ) 2 | ( for the optional word sets only use standard words from the Core word set. ) 3 | ( This file, which is included *after* the Core test programs, contains ) 4 | ( various definitions for use by the optional word set test programs to ) 5 | ( remove any dependencies between word sets. ) 6 | 7 | DECIMAL 8 | 9 | ( First a definition to see if a word is already defined. Note that ) 10 | ( [DEFINED] [IF] [ELSE] and [THEN] are in the optional Programming Tools ) 11 | ( word set. ) 12 | 13 | VARIABLE (\?) 0 (\?) ! ( Flag: Word defined = 0 | word undefined = -1 ) 14 | 15 | ( [?DEF] followed by [?IF] cannot be used again until after [THEN] ) 16 | : [?DEF] ( "name" -- ) 17 | BL WORD FIND SWAP DROP 0= (\?) ! 18 | ; 19 | 20 | \ Test [?DEF] 21 | T{ 0 (\?) ! [?DEF] ?DEFTEST1 (\?) @ -> -1 }T 22 | : ?DEFTEST1 1 ; 23 | T{ -1 (\?) ! [?DEF] ?DEFTEST1 (\?) @ -> 0 }T 24 | 25 | : [?UNDEF] [?DEF] (\?) @ 0= (\?) ! ; 26 | 27 | \ Equivalents of [IF] [ELSE] [THEN], these must not be nested 28 | : [?IF] ( f -- ) (\?) ! ; IMMEDIATE 29 | : [?ELSE] ( -- ) (\?) @ 0= (\?) ! ; IMMEDIATE 30 | : [?THEN] ( -- ) 0 (\?) ! ; IMMEDIATE 31 | 32 | ( A conditional comment and \ will be defined. Note that these definitions ) 33 | ( are inadequate for use in Forth blocks. If needed in the blocks test ) 34 | ( program they will need to be modified here or redefined there ) 35 | 36 | ( \? is a conditional comment ) 37 | : \? ( "..." -- ) (\?) @ IF EXIT THEN SOURCE >IN ! DROP ; IMMEDIATE 38 | 39 | \ Test \? 40 | T{ [?DEF] ?DEFTEST1 \? : ?DEFTEST1 2 ; \ Should not be redefined 41 | ?DEFTEST1 -> 1 }T 42 | T{ [?DEF] ?DEFTEST2 \? : ?DEFTEST1 2 ; \ Should be redefined 43 | ?DEFTEST1 -> 2 }T 44 | 45 | [?DEF] TRUE \? -1 CONSTANT TRUE 46 | [?DEF] FALSE \? 0 CONSTANT FALSE 47 | [?DEF] NIP \? : NIP SWAP DROP ; 48 | [?DEF] TUCK \? : TUCK SWAP OVER ; 49 | 50 | [?DEF] PARSE 51 | \? : BUMP ( caddr u n -- caddr+n u-n ) 52 | \? TUCK - >R CHARS + R> 53 | \? ; 54 | 55 | \? : PARSE ( ch "ccc" -- caddr u ) 56 | \? >R SOURCE >IN @ BUMP 57 | \? OVER R> SWAP >R >R ( -- start u1 ) ( R: -- start ch ) 58 | \? BEGIN 59 | \? DUP 60 | \? WHILE 61 | \? OVER C@ R@ = 0= 62 | \? WHILE 63 | \? 1 BUMP 64 | \? REPEAT 65 | \? 1- ( end u2 ) \ delimiter found 66 | \? THEN 67 | \? SOURCE NIP SWAP - >IN ! ( -- end ) 68 | \? R> DROP R> ( -- end start ) 69 | \? TUCK - 1 CHARS / ( -- start u ) 70 | \? ; 71 | 72 | [?DEF] .( \? : .( [CHAR] ) PARSE TYPE ; IMMEDIATE 73 | 74 | \ S= to compare (case sensitive) two strings to avoid use of COMPARE from 75 | \ the String word set. It is defined in core.fr and conditionally defined 76 | \ here if core.fr has not been included by the user 77 | 78 | [?DEF] S= 79 | \? : S= ( caddr1 u1 caddr2 u2 -- f ) \ f = TRUE if strings are equal 80 | \? ROT OVER = 0= IF DROP 2DROP FALSE EXIT THEN 81 | \? DUP 0= IF DROP 2DROP TRUE EXIT THEN 82 | \? 0 DO 83 | \? OVER C@ OVER C@ = 0= IF 2DROP FALSE UNLOOP EXIT THEN 84 | \? CHAR+ SWAP CHAR+ 85 | \? LOOP 2DROP TRUE 86 | \? ; 87 | 88 | \ Buffer for strings in interpretive mode since S" only valid in compilation 89 | \ mode when File-Access word set is defined 90 | 91 | 64 CONSTANT SBUF-SIZE 92 | CREATE SBUF1 SBUF-SIZE CHARS ALLOT 93 | CREATE SBUF2 SBUF-SIZE CHARS ALLOT 94 | 95 | \ ($") saves a counted string at (caddr) 96 | : ($") ( caddr "ccc" -- caddr' u ) 97 | [CHAR] " PARSE ROT 2DUP C! ( -- ca2 u2 ca) 98 | CHAR+ SWAP 2DUP 2>R CHARS MOVE ( -- ) ( R: -- ca' u2 ) 99 | 2R> 100 | ; 101 | 102 | : $" ( "ccc" -- caddr u ) SBUF1 ($") ; 103 | : $2" ( "ccc" -- caddr u ) SBUF2 ($") ; 104 | : $CLEAR ( caddr -- ) SBUF-SIZE BL FILL ; 105 | : CLEAR-SBUFS ( -- ) SBUF1 $CLEAR SBUF2 $CLEAR ; 106 | 107 | \ More definitions in core.fr used in other test programs, conditionally 108 | \ defined here if core.fr has not been loaded 109 | 110 | [?DEF] MAX-UINT \? 0 INVERT CONSTANT MAX-UINT 111 | [?DEF] MAX-INT \? 0 INVERT 1 RSHIFT CONSTANT MAX-INT 112 | [?DEF] MIN-INT \? 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT 113 | [?DEF] MID-UINT \? 0 INVERT 1 RSHIFT CONSTANT MID-UINT 114 | [?DEF] MID-UINT+1 \? 0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 115 | 116 | [?DEF] 2CONSTANT \? : 2CONSTANT CREATE , , DOES> 2@ ; 117 | 118 | BASE @ 2 BASE ! -1 0 <# #S #> SWAP DROP CONSTANT BITS/CELL BASE ! 119 | 120 | 121 | \ ------------------------------------------------------------------------------ 122 | \ Tests 123 | 124 | : STR1 S" abcd" ; : STR2 S" abcde" ; 125 | : STR3 S" abCd" ; : STR4 S" wbcd" ; 126 | : S"" S" " ; 127 | 128 | T{ STR1 2DUP S= -> TRUE }T 129 | T{ STR2 2DUP S= -> TRUE }T 130 | T{ S"" 2DUP S= -> TRUE }T 131 | T{ STR1 STR2 S= -> FALSE }T 132 | T{ STR1 STR3 S= -> FALSE }T 133 | T{ STR1 STR4 S= -> FALSE }T 134 | 135 | T{ CLEAR-SBUFS -> }T 136 | T{ $" abcdefghijklm" SBUF1 COUNT S= -> TRUE }T 137 | T{ $" nopqrstuvwxyz" SBUF2 OVER S= -> FALSE }T 138 | T{ $2" abcdefghijklm" SBUF1 COUNT S= -> FALSE }T 139 | T{ $2" nopqrstuvwxyz" SBUF1 COUNT S= -> TRUE }T 140 | 141 | \ ------------------------------------------------------------------------------ 142 | 143 | CR $" Test utilities loaded" TYPE CR 144 | 145 | -------------------------------------------------------------------------------- /xc.py: -------------------------------------------------------------------------------- 1 | # C64 Cross Compiler 2 | 3 | import os 4 | import re 5 | import sys 6 | 7 | NEWLINE = 256 8 | 9 | OUT = None 10 | 11 | refs = {} 12 | 13 | to_petscii = [ 14 | 0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a,0x0b,0x0c,0x0d,0x0e,0x0f, 15 | 0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0x1a,0x1b,0x1c,0x1d,0x1e,0x1f, 16 | 0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28,0x29,0x2a,0x2b,0x2c,0x2d,0x2e,0x2f, 17 | 0x30,0x31,0x32,0x33,0x34,0x35,0x36,0x37,0x38,0x39,0x3a,0x3b,0x3c,0x3d,0x3e,0x3f, 18 | 0x40,0xc1,0xc2,0xc3,0xc4,0xc5,0xc6,0xc7,0xc8,0xc9,0xca,0xcb,0xcc,0xcd,0xce,0xcf, 19 | 0xd0,0xd1,0xd2,0xd3,0xd4,0xd5,0xd6,0xd7,0xd8,0xd9,0xda,0x5b,0x5c,0x5d,0x5e,0x5f, 20 | 0xc0,0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4a,0x4b,0x4c,0x4d,0x4e,0x4f, 21 | 0x50,0x51,0x52,0x53,0x54,0x55,0x56,0x57,0x58,0x59,0x5a,0xdb,0xdc,0xdd,0xde,0xdf, 22 | 0x80,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x8a,0x8b,0x8c,0x8d,0x8e,0x8f, 23 | 0x90,0x91,0x92,0x0c,0x94,0x95,0x96,0x97,0x98,0x99,0x9a,0x9b,0x9c,0x9d,0x9e,0x9f, 24 | 0xa0,0xa1,0xa2,0xa3,0xa4,0xa5,0xa6,0xa7,0xa8,0xa9,0xaa,0xab,0xac,0xad,0xae,0xaf, 25 | 0xb0,0xb1,0xb2,0xb3,0xb4,0xb5,0xb6,0xb7,0xb8,0xb9,0xba,0xbb,0xbc,0xbd,0xbe,0xbf, 26 | 0x60,0x61,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6a,0x6b,0x6c,0x6d,0x6e,0x6f, 27 | 0x70,0x71,0x72,0x73,0x74,0x75,0x76,0x77,0x78,0x79,0x7a,0x7b,0x7c,0x7d,0x7e,0x7f, 28 | 0xe0,0xe1,0xe2,0xe3,0xe4,0xe5,0xe6,0xe7,0xe8,0xe9,0xea,0xeb,0xec,0xed,0xee,0xef, 29 | 0xf0,0xf1,0xf2,0xf3,0xf4,0xf5,0xf6,0xf7,0xf8,0xf9,0xfa,0xfb,0xfc,0xfd,0xfe,0xff, 30 | 0xd # \n 31 | ] 32 | 33 | class Ref: 34 | def __init__(self, addr, word = None): 35 | self.addr = addr 36 | self.word = word 37 | if word: 38 | if not addr in refs: 39 | refs[addr] = [] 40 | refs[addr].append(word) 41 | 42 | def __index__(self): 43 | return self.addr 44 | 45 | def __int__(self): 46 | return self.addr 47 | 48 | # ? 49 | def __sub__(self, other): 50 | return self.addr - other 51 | def __rsub__(self, other): 52 | return other - self.addr 53 | def __add__(self, other): 54 | return other + self.addr 55 | def __radd__(self, other): 56 | return other + self.addr 57 | def __lt__(self, other): 58 | if type(other) == Ref: 59 | return self.addr < other.addr 60 | else: 61 | return self.addr < other 62 | def __eq__(self, other): 63 | return self.addr == other 64 | 65 | word_hashes = [] 66 | def word_name_hash(word_name): 67 | if word_name not in word_hashes: 68 | word_hashes.append(word_name) 69 | return "WORD_" + str(word_hashes.index(word_name)) 70 | 71 | def compile(dictionary_, heap_, start_word_name, outfile): 72 | global dictionary 73 | global heap 74 | global OUT 75 | 76 | OUT = open(outfile, "w") 77 | 78 | dictionary = dictionary_ 79 | heap = heap_ 80 | 81 | words_to_export.append(dictionary.words[start_word_name]) 82 | 83 | write_header() 84 | 85 | while True: 86 | if words_to_export: 87 | export_word(words_to_export.pop()) 88 | continue 89 | if primitives_to_add: 90 | add_primitive(primitives_to_add.pop()) 91 | continue 92 | if doers_to_export: 93 | export_doer(doers_to_export.pop()) 94 | continue 95 | break 96 | 97 | words_to_export = [] 98 | exported_words = set() 99 | 100 | doers_to_export = [] 101 | exported_doers = set() 102 | 103 | primitives_to_add = [] 104 | added_primitives = set() 105 | 106 | def add_primitive_dependency(word_name): 107 | if word_name not in added_primitives: 108 | primitives_to_add.append(word_name) 109 | 110 | def export_word(w): 111 | if w in exported_words: 112 | return 113 | exported_words.add(w) 114 | 115 | xt = w.xt 116 | 117 | if w.body != None: 118 | compile_forth_word(w) 119 | else: 120 | add_primitive_dependency(w.name) 121 | 122 | def compile_forth_word(w): 123 | s = str(w.xt) 124 | if "COLON" in s: 125 | compile_colon_word(w) 126 | elif "CREATE" in s: 127 | compile_create_word(w) 128 | elif "CONSTANT" in s: 129 | compile_constant_word(w) 130 | elif "DOES_TO" in s: 131 | compile_does_word(w) 132 | elif "HERE" in s: 133 | OUT.write("; raw data area\n") 134 | compile_body(w) 135 | else: 136 | sys.exit("Unknown xt " + str(w.xt)) 137 | 138 | def compile_constant_word(w): 139 | OUT.write(word_name_hash(w.name) + "\t; " + w.name + "\n") 140 | if type(w.constant_value) == Ref: 141 | OUT.write("\tldy\t#>REF_" + str(w.constant_value.addr) + "_W_" + str(w.constant_value.word.body) + "\n") 142 | OUT.write("\tlda\t#> 8) & 0xff) + "\n") 148 | OUT.write("\tlda\t#" + str(w.constant_value & 0xff) + "\n") 149 | elif callable(w.constant_value): 150 | word = dictionary.xt_words[w.constant_value] 151 | if word not in words_to_export: 152 | words_to_export.append(word) 153 | OUT.write("\tldy\t#>" + word_name_hash(word.name) + "\t; " + word.name + "\n") 154 | OUT.write("\tlda\t#<" + word_name_hash(word.name) + "\t; " + word.name + "\n") 155 | else: 156 | print(w.constant_value) 157 | assert False 158 | OUT.write("\tjmp\t" + word_name_hash("pushya") + "\t; pushya\n\n") 159 | add_primitive_dependency("pushya") 160 | 161 | def compile_create_word(w): 162 | OUT.write(word_name_hash(w.name) + "\t; " + w.name + "\n") 163 | OUT.write("\tldy\t#>IP_" + str(w.body) + "\n") 164 | OUT.write("\tlda\t#>>" + word_name + "<<<") 319 | 320 | def write_header(): 321 | location = os.path.realpath(os.path.join(os.getcwd(), os.path.dirname(__file__))) 322 | asm_header_path = os.path.join(location, "src/header.asm") 323 | OUT.write(open(asm_header_path, "r").read() + "\n") 324 | 325 | def export_doer(ip): 326 | if ip in exported_doers: 327 | return 328 | exported_doers.add(ip) 329 | for w in dictionary.words.values(): 330 | if w.body and w.body_end and w.body <= ip and ip < w.body_end: 331 | OUT.write("\t;doer " + w.name + "\n") 332 | compile_body(w, ip) 333 | return 334 | assert False 335 | -------------------------------------------------------------------------------- /test/testcoreplus.fs: -------------------------------------------------------------------------------- 1 | \ Additional tests on the the ANS Forth Core word set 2 | 3 | \ This program was written by Gerry Jackson in 2007, with contributions from 4 | \ others where indicated, and is in the public domain - it can be distributed 5 | \ and/or modified in any way but please retain this notice. 6 | 7 | \ This program is distributed in the hope that it will be useful, 8 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | 11 | \ The tests are not claimed to be comprehensive or correct 12 | 13 | \ ------------------------------------------------------------------------------ 14 | \ The tests are based on John Hayes test program for the core word set 15 | \ 16 | \ This file provides some more tests on Core words where the original Hayes 17 | \ tests are thought to be incomplete 18 | \ 19 | \ Words tested in this file are: 20 | \ DO I +LOOP RECURSE ELSE >IN IMMEDIATE FIND IF...BEGIN...REPEAT ALLOT DOES> 21 | \ and 22 | \ Parsing behaviour 23 | \ Number prefixes # $ % and 'A' character input 24 | \ Definition names 25 | \ ------------------------------------------------------------------------------ 26 | \ Assumptions and dependencies: 27 | \ - tester.fr or ttester.fs has been loaded prior to this file 28 | \ - core.fr has been loaded so that constants MAX-INT, MIN-INT and 29 | \ MAX-UINT are defined 30 | \ ------------------------------------------------------------------------------ 31 | 32 | DECIMAL 33 | 34 | TESTING DO +LOOP with run-time increment, negative increment, infinite loop 35 | \ Contributed by Reinhold Straub 36 | 37 | VARIABLE ITERATIONS 38 | VARIABLE INCREMENT 39 | : GD7 ( LIMIT START INCREMENT -- ) 40 | INCREMENT ! 41 | 0 ITERATIONS ! 42 | DO 43 | 1 ITERATIONS +! 44 | I 45 | ITERATIONS @ 6 = IF LEAVE THEN 46 | INCREMENT @ 47 | +LOOP ITERATIONS @ 48 | ; 49 | 50 | T{ 4 4 -1 GD7 -> 4 1 }T 51 | T{ 1 4 -1 GD7 -> 4 3 2 1 4 }T 52 | T{ 4 1 -1 GD7 -> 1 0 -1 -2 -3 -4 6 }T 53 | T{ 4 1 0 GD7 -> 1 1 1 1 1 1 6 }T 54 | T{ 0 0 0 GD7 -> 0 0 0 0 0 0 6 }T 55 | T{ 1 4 0 GD7 -> 4 4 4 4 4 4 6 }T 56 | T{ 1 4 1 GD7 -> 4 5 6 7 8 9 6 }T 57 | T{ 4 1 1 GD7 -> 1 2 3 3 }T 58 | T{ 4 4 1 GD7 -> 4 5 6 7 8 9 6 }T 59 | T{ 2 -1 -1 GD7 -> -1 -2 -3 -4 -5 -6 6 }T 60 | T{ -1 2 -1 GD7 -> 2 1 0 -1 4 }T 61 | T{ 2 -1 0 GD7 -> -1 -1 -1 -1 -1 -1 6 }T 62 | T{ -1 2 0 GD7 -> 2 2 2 2 2 2 6 }T 63 | T{ -1 2 1 GD7 -> 2 3 4 5 6 7 6 }T 64 | T{ 2 -1 1 GD7 -> -1 0 1 3 }T 65 | T{ -20 30 -10 GD7 -> 30 20 10 0 -10 -20 6 }T 66 | T{ -20 31 -10 GD7 -> 31 21 11 1 -9 -19 6 }T 67 | T{ -20 29 -10 GD7 -> 29 19 9 -1 -11 5 }T 68 | 69 | \ ------------------------------------------------------------------------------ 70 | TESTING DO +LOOP with large and small increments 71 | 72 | \ Contributed by Andrew Haley 73 | 74 | MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP 75 | USTEP NEGATE CONSTANT -USTEP 76 | MAX-INT 7 RSHIFT 1+ CONSTANT STEP 77 | STEP NEGATE CONSTANT -STEP 78 | 79 | VARIABLE BUMP 80 | 81 | T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; -> }T 82 | 83 | T{ 0 MAX-UINT 0 USTEP GD8 -> 256 }T 84 | T{ 0 0 MAX-UINT -USTEP GD8 -> 256 }T 85 | 86 | T{ 0 MAX-INT MIN-INT STEP GD8 -> 256 }T 87 | T{ 0 MIN-INT MAX-INT -STEP GD8 -> 256 }T 88 | 89 | \ Two's complement arithmetic, wraps around modulo wordsize 90 | \ Only tested if the Forth system does wrap around, use of conditional 91 | \ compilation deliberately avoided 92 | 93 | MAX-INT 1+ MIN-INT = CONSTANT +WRAP? 94 | MIN-INT 1- MAX-INT = CONSTANT -WRAP? 95 | MAX-UINT 1+ 0= CONSTANT +UWRAP? 96 | 0 1- MAX-UINT = CONSTANT -UWRAP? 97 | 98 | : GD9 ( n limit start step f result -- ) 99 | >R IF GD8 ELSE 2DROP 2DROP R@ THEN -> R> }T 100 | ; 101 | 102 | T{ 0 0 0 USTEP +UWRAP? 256 GD9 103 | T{ 0 0 0 -USTEP -UWRAP? 1 GD9 104 | T{ 0 MIN-INT MAX-INT STEP +WRAP? 1 GD9 105 | T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9 106 | 107 | \ ------------------------------------------------------------------------------ 108 | TESTING DO +LOOP with maximum and minimum increments 109 | 110 | : (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ; 111 | (-MI) CONSTANT -MAX-INT 112 | 113 | T{ 0 1 0 MAX-INT GD8 -> 1 }T 114 | T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8 -> 2 }T 115 | 116 | T{ 0 MAX-INT 0 MAX-INT GD8 -> 1 }T 117 | T{ 0 MAX-INT 1 MAX-INT GD8 -> 1 }T 118 | T{ 0 MAX-INT -1 MAX-INT GD8 -> 2 }T 119 | T{ 0 MAX-INT DUP 1- MAX-INT GD8 -> 1 }T 120 | 121 | T{ 0 MIN-INT 1+ 0 MIN-INT GD8 -> 1 }T 122 | T{ 0 MIN-INT 1+ -1 MIN-INT GD8 -> 1 }T 123 | T{ 0 MIN-INT 1+ 1 MIN-INT GD8 -> 2 }T 124 | T{ 0 MIN-INT 1+ DUP MIN-INT GD8 -> 1 }T 125 | 126 | \ ------------------------------------------------------------------------------ 127 | \ TESTING +LOOP setting I to an arbitrary value 128 | 129 | \ The specification for +LOOP permits the loop index I to be set to any value 130 | \ including a value outside the range given to the corresponding DO. 131 | 132 | \ SET-I is a helper to set I in a DO ... +LOOP to a given value 133 | \ n2 is the value of I in a DO ... +LOOP 134 | \ n3 is a test value 135 | \ If n2=n3 then return n1-n2 else return 1 136 | : SET-I ( n1 n2 n3 -- n1-n2 | 1 ) 137 | OVER = IF - ELSE 2DROP 1 THEN 138 | ; 139 | 140 | : -SET-I ( n1 n2 n3 -- n1-n2 | -1 ) 141 | SET-I DUP 1 = IF NEGATE THEN 142 | ; 143 | 144 | : PL1 20 1 DO I 18 I 3 SET-I +LOOP ; 145 | T{ PL1 -> 1 2 3 18 19 }T 146 | : PL2 20 1 DO I 20 I 2 SET-I +LOOP ; 147 | T{ PL2 -> 1 2 }T 148 | : PL3 20 5 DO I 19 I 2 SET-I DUP 1 = IF DROP 0 I 6 SET-I THEN +LOOP ; 149 | T{ PL3 -> 5 6 0 1 2 19 }T 150 | : PL4 20 1 DO I MAX-INT I 4 SET-I +LOOP ; 151 | T{ PL4 -> 1 2 3 4 }T 152 | : PL5 -20 -1 DO I -19 I -3 -SET-I +LOOP ; 153 | T{ PL5 -> -1 -2 -3 -19 -20 }T 154 | : PL6 -20 -1 DO I -21 I -4 -SET-I +LOOP ; 155 | T{ PL6 -> -1 -2 -3 -4 }T 156 | : PL7 -20 -1 DO I MIN-INT I -5 -SET-I +LOOP ; 157 | T{ PL7 -> -1 -2 -3 -4 -5 }T 158 | : PL8 -20 -5 DO I -20 I -2 -SET-I DUP -1 = IF DROP 0 I -6 -SET-I THEN +LOOP ; 159 | T{ PL8 -> -5 -6 0 -1 -2 -20 }T 160 | 161 | \ ------------------------------------------------------------------------------ 162 | TESTING multiple RECURSEs in one colon definition 163 | 164 | : ACK ( m n -- u ) \ Ackermann function, from Rosetta Code 165 | OVER 0= IF NIP 1+ EXIT THEN \ ack(0, n) = n+1 166 | SWAP 1- SWAP ( -- m-1 n ) 167 | DUP 0= IF 1+ RECURSE EXIT THEN \ ack(m, 0) = ack(m-1, 1) 168 | 1- OVER 1+ SWAP RECURSE RECURSE \ ack(m, n) = ack(m-1, ack(m,n-1)) 169 | ; 170 | 171 | T{ 0 0 ACK -> 1 }T 172 | T{ 3 0 ACK -> 5 }T 173 | T{ 2 4 ACK -> 11 }T 174 | 175 | \ ------------------------------------------------------------------------------ 176 | TESTING multiple ELSE's in an IF statement 177 | \ Discussed on comp.lang.forth and accepted as valid ANS Forth 178 | 179 | : MELSE IF 1 ELSE 2 ELSE 3 ELSE 4 ELSE 5 THEN ; 180 | T{ 0 MELSE -> 2 4 }T 181 | T{ -1 MELSE -> 1 3 5 }T 182 | 183 | \ ------------------------------------------------------------------------------ 184 | TESTING manipulation of >IN in interpreter mode 185 | 186 | T{ 12345 DEPTH OVER 9 < 34 AND + 3 + >IN ! -> 12345 2345 345 45 5 }T 187 | T{ 14145 8115 ?DUP 0= 34 AND >IN +! TUCK MOD 14 >IN ! GCD CALCULATION -> 15 }T 188 | 189 | \ ------------------------------------------------------------------------------ 190 | TESTING IMMEDIATE with CONSTANT VARIABLE and CREATE [ ... DOES> ] 191 | 192 | T{ 123 CONSTANT IW1 IMMEDIATE IW1 -> 123 }T 193 | T{ : IW2 IW1 LITERAL ; IW2 -> 123 }T 194 | T{ VARIABLE IW3 IMMEDIATE 234 IW3 ! IW3 @ -> 234 }T 195 | T{ : IW4 IW3 [ @ ] LITERAL ; IW4 -> 234 }T 196 | T{ :NONAME [ 345 ] IW3 [ ! ] ; DROP IW3 @ -> 345 }T 197 | T{ CREATE IW5 456 , IMMEDIATE -> }T 198 | T{ :NONAME IW5 [ @ IW3 ! ] ; DROP IW3 @ -> 456 }T 199 | T{ : IW6 CREATE , IMMEDIATE DOES> @ 1+ ; -> }T 200 | T{ 111 IW6 IW7 IW7 -> 112 }T 201 | T{ : IW8 IW7 LITERAL 1+ ; IW8 -> 113 }T 202 | T{ : IW9 CREATE , DOES> @ 2 + IMMEDIATE ; -> }T 203 | : FIND-IW BL WORD FIND NIP ; ( -- 0 | 1 | -1 ) 204 | T{ 222 IW9 IW10 FIND-IW IW10 -> -1 }T \ IW10 is not immediate 205 | T{ IW10 FIND-IW IW10 -> 224 1 }T \ IW10 becomes immediate 206 | 207 | \ ------------------------------------------------------------------------------ 208 | TESTING that IMMEDIATE doesn't toggle a flag 209 | 210 | VARIABLE IT1 0 IT1 ! 211 | : IT2 1234 IT1 ! ; IMMEDIATE IMMEDIATE 212 | T{ : IT3 IT2 ; IT1 @ -> 1234 }T 213 | 214 | \ ------------------------------------------------------------------------------ 215 | TESTING parsing behaviour of S" ." and ( 216 | \ which should parse to just beyond the terminating character no space needed 217 | 218 | T{ : GC5 S" A string"2DROP ; GC5 -> }T 219 | T{ ( A comment)1234 -> 1234 }T 220 | T{ : PB1 CR ." You should see 2345: "." 2345"( A comment) CR ; PB1 -> }T 221 | 222 | \ ------------------------------------------------------------------------------ 223 | TESTING number prefixes # $ % and 'c' character input 224 | \ Adapted from the Forth 200X Draft 14.5 document 225 | 226 | VARIABLE OLD-BASE 227 | DECIMAL BASE @ OLD-BASE ! 228 | T{ #1289 -> 1289 }T 229 | T{ #-1289 -> -1289 }T 230 | T{ $12eF -> 4847 }T 231 | T{ $-12eF -> -4847 }T 232 | T{ %10010110 -> 150 }T 233 | T{ %-10010110 -> -150 }T 234 | T{ 'z' -> 122 }T 235 | T{ 'Z' -> 90 }T 236 | \ Check BASE is unchanged 237 | T{ BASE @ OLD-BASE @ = -> }T 238 | 239 | \ Repeat in Hex mode 240 | 16 OLD-BASE ! 16 BASE ! 241 | T{ #1289 -> 509 }T 242 | T{ #-1289 -> -509 }T 243 | T{ $12eF -> 12EF }T 244 | T{ $-12eF -> -12EF }T 245 | T{ %10010110 -> 96 }T 246 | T{ %-10010110 -> -96 }T 247 | T{ 'z' -> 7a }T 248 | T{ 'Z' -> 5a }T 249 | \ Check BASE is unchanged 250 | T{ BASE @ OLD-BASE @ = -> }T \ 2 251 | 252 | DECIMAL 253 | \ Check number prefixes in compile mode 254 | T{ : nmp #8327 $-2cbe %011010111 ''' ; nmp -> 8327 -11454 215 39 }T 255 | 256 | \ ------------------------------------------------------------------------------ 257 | TESTING definition names 258 | \ should support {1..31} graphical characters 259 | : !"#$%&'()*+,-./0123456789:;<=>? 1 ; 260 | T{ !"#$%&'()*+,-./0123456789:;<=>? -> 1 }T 261 | : @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ 2 ; 262 | T{ @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ -> 2 }T 263 | : _`abcdefghijklmnopqrstuvwxyz{|} 3 ; 264 | T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T 265 | : _`abcdefghijklmnopqrstuvwxyz{|~ 4 ; \ Last character different 266 | T{ _`abcdefghijklmnopqrstuvwxyz{|~ -> 4 }T 267 | T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T 268 | 269 | \ ------------------------------------------------------------------------------ 270 | TESTING FIND with a zero length string and a non-existent word 271 | 272 | CREATE EMPTYSTRING 0 C, 273 | : EMPTYSTRING-FIND-CHECK ( c-addr 0 | xt 1 | xt -1 -- t|f ) 274 | DUP IF ." FIND returns a TRUE value for an empty string!" CR THEN 275 | 0= SWAP EMPTYSTRING = = ; 276 | T{ EMPTYSTRING FIND EMPTYSTRING-FIND-CHECK -> }T 277 | 278 | CREATE NON-EXISTENT-WORD \ Same as in exceptiontest.fth 279 | 15 C, CHAR $ C, CHAR $ C, CHAR Q C, CHAR W C, CHAR E C, CHAR Q C, 280 | CHAR W C, CHAR E C, CHAR Q C, CHAR W C, CHAR E C, CHAR R C, CHAR T C, 281 | CHAR $ C, CHAR $ C, 282 | T{ NON-EXISTENT-WORD FIND -> NON-EXISTENT-WORD 0 }T 283 | 284 | \ ------------------------------------------------------------------------------ 285 | TESTING IF ... BEGIN ... REPEAT (unstructured) 286 | 287 | T{ : UNS1 DUP 0 > IF 9 SWAP BEGIN 1+ DUP 3 > IF EXIT THEN REPEAT ; -> }T 288 | T{ -6 UNS1 -> -6 }T 289 | T{ 1 UNS1 -> 9 4 }T 290 | 291 | \ ------------------------------------------------------------------------------ 292 | TESTING DOES> doesn't cause a problem with a CREATEd address 293 | 294 | : MAKE-2CONST DOES> 2@ ; 295 | T{ CREATE 2K 3 , 2K , MAKE-2CONST 2K -> ' 2K >BODY 3 }T 296 | 297 | \ ------------------------------------------------------------------------------ 298 | TESTING ALLOT ( n -- ) where n <= 0 299 | 300 | T{ HERE 5 ALLOT -5 ALLOT HERE = -> }T 301 | T{ HERE 0 ALLOT HERE = -> }T 302 | 303 | \ ------------------------------------------------------------------------------ 304 | 305 | CR .( End of additional Core tests) CR 306 | 307 | -------------------------------------------------------------------------------- /test/testcoreext.fs: -------------------------------------------------------------------------------- 1 | \ To test the ANS Forth Core Extension word set 2 | 3 | \ This program was written by Gerry Jackson in 2006, with contributions from 4 | \ others where indicated, and is in the public domain - it can be distributed 5 | \ and/or modified in any way but please retain this notice. 6 | 7 | \ This program is distributed in the hope that it will be useful, 8 | \ but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 10 | 11 | \ The tests are not claimed to be comprehensive or correct 12 | 13 | \ ------------------------------------------------------------------------------ 14 | \ Version 0.13 28 October 2015 15 | \ Replace and with FALSE and TRUE to avoid 16 | \ dependence on Core tests 17 | \ Moved SAVE-INPUT and RESTORE-INPUT tests in a file to filetest.fth 18 | \ Use of 2VARIABLE (from optional wordset) replaced with CREATE. 19 | \ Minor lower to upper case conversions. 20 | \ Calls to COMPARE replaced by S= (in utilities.fth) to avoid use 21 | \ of a word from an optional word set. 22 | \ UNUSED tests revised as UNUSED UNUSED = may return FALSE when an 23 | \ implementation has the data stack sharing unused dataspace. 24 | \ Double number input dependency removed from the HOLDS tests. 25 | \ Minor case sensitivities removed in definition names. 26 | \ 0.11 25 April 2015 27 | \ Added tests for PARSE-NAME HOLDS BUFFER: 28 | \ S\" tests added 29 | \ DEFER IS ACTION-OF DEFER! DEFER@ tests added 30 | \ Empty CASE statement test added 31 | \ [COMPILE] tests removed because it is obsolescent in Forth 2012 32 | \ 0.10 1 August 2014 33 | \ Added tests contributed by James Bowman for: 34 | \ <> U> 0<> 0> NIP TUCK ROLL PICK 2>R 2R@ 2R> 35 | \ HEX WITHIN UNUSED AGAIN MARKER 36 | \ Added tests for: 37 | \ .R U.R ERASE PAD REFILL SOURCE-ID 38 | \ Removed ABORT from NeverExecuted to enable Win32 39 | \ to continue after failure of RESTORE-INPUT. 40 | \ Removed max-intx which is no longer used. 41 | \ 0.7 6 June 2012 Extra CASE test added 42 | \ 0.6 1 April 2012 Tests placed in the public domain. 43 | \ SAVE-INPUT & RESTORE-INPUT tests, position 44 | \ of T{ moved so that tests work with ttester.fs 45 | \ CONVERT test deleted - obsolete word removed from Forth 200X 46 | \ IMMEDIATE VALUEs tested 47 | \ RECURSE with :NONAME tested 48 | \ PARSE and .( tested 49 | \ Parsing behaviour of C" added 50 | \ 0.5 14 September 2011 Removed the double [ELSE] from the 51 | \ initial SAVE-INPUT & RESTORE-INPUT test 52 | \ 0.4 30 November 2009 max-int replaced with max-intx to 53 | \ avoid redefinition warnings. 54 | \ 0.3 6 March 2009 { and } replaced with T{ and }T 55 | \ CONVERT test now independent of cell size 56 | \ 0.2 20 April 2007 ANS Forth words changed to upper case 57 | \ Tests qd3 to qd6 by Reinhold Straub 58 | \ 0.1 Oct 2006 First version released 59 | \ ----------------------------------------------------------------------------- 60 | \ The tests are based on John Hayes test program for the core word set 61 | 62 | \ Words tested in this file are: 63 | \ .( .R 0<> 0> 2>R 2R> 2R@ :NONAME <> ?DO AGAIN C" CASE COMPILE, ENDCASE 64 | \ ENDOF ERASE FALSE HEX MARKER NIP OF PAD PARSE PICK REFILL 65 | \ RESTORE-INPUT ROLL SAVE-INPUT SOURCE-ID TO TRUE TUCK U.R U> UNUSED 66 | \ VALUE WITHIN [COMPILE] 67 | 68 | \ Words not tested or partially tested: 69 | \ \ because it has been extensively used already and is, hence, unnecessary 70 | \ REFILL and SOURCE-ID from the user input device which are not possible 71 | \ when testing from a file such as this one 72 | \ UNUSED (partially tested) as the value returned is system dependent 73 | \ Obsolescent words #TIB CONVERT EXPECT QUERY SPAN TIB as they have been 74 | \ removed from the Forth 2012 standard 75 | 76 | \ Results from words that output to the user output device have to visually 77 | \ checked for correctness. These are .R U.R .( 78 | 79 | \ ----------------------------------------------------------------------------- 80 | \ Assumptions & dependencies: 81 | \ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been 82 | \ included prior to this file 83 | \ - the Core word set available 84 | \ ----------------------------------------------------------------------------- 85 | TESTING Core Extension words 86 | 87 | DECIMAL 88 | 89 | TESTING TRUE FALSE 90 | 91 | T{ TRUE -> 0 INVERT }T 92 | T{ FALSE -> 0 }T 93 | 94 | \ ----------------------------------------------------------------------------- 95 | TESTING <> U> (contributed by James Bowman) 96 | 97 | T{ 0 0 <> -> FALSE }T 98 | T{ 1 1 <> -> FALSE }T 99 | T{ -1 -1 <> -> FALSE }T 100 | T{ 1 0 <> -> TRUE }T 101 | T{ -1 0 <> -> TRUE }T 102 | T{ 0 1 <> -> TRUE }T 103 | T{ 0 -1 <> -> TRUE }T 104 | 105 | T{ 0 1 U> -> FALSE }T 106 | T{ 1 2 U> -> FALSE }T 107 | T{ 0 MID-UINT U> -> FALSE }T 108 | T{ 0 MAX-UINT U> -> FALSE }T 109 | T{ MID-UINT MAX-UINT U> -> FALSE }T 110 | T{ 0 0 U> -> FALSE }T 111 | T{ 1 1 U> -> FALSE }T 112 | T{ 1 0 U> -> TRUE }T 113 | T{ 2 1 U> -> TRUE }T 114 | T{ MID-UINT 0 U> -> TRUE }T 115 | T{ MAX-UINT 0 U> -> TRUE }T 116 | T{ MAX-UINT MID-UINT U> -> TRUE }T 117 | 118 | \ ----------------------------------------------------------------------------- 119 | TESTING 0<> 0> (contributed by James Bowman) 120 | 121 | T{ 0 0<> -> FALSE }T 122 | T{ 1 0<> -> TRUE }T 123 | T{ 2 0<> -> TRUE }T 124 | T{ -1 0<> -> TRUE }T 125 | T{ MAX-UINT 0<> -> TRUE }T 126 | T{ MIN-INT 0<> -> TRUE }T 127 | T{ MAX-INT 0<> -> TRUE }T 128 | 129 | T{ 0 0> -> FALSE }T 130 | T{ -1 0> -> FALSE }T 131 | T{ MIN-INT 0> -> FALSE }T 132 | T{ 1 0> -> TRUE }T 133 | T{ MAX-INT 0> -> TRUE }T 134 | 135 | \ ----------------------------------------------------------------------------- 136 | TESTING NIP TUCK ROLL PICK (contributed by James Bowman) 137 | 138 | T{ 1 2 NIP -> 2 }T 139 | T{ 1 2 3 NIP -> 1 3 }T 140 | 141 | T{ 1 2 TUCK -> 2 1 2 }T 142 | T{ 1 2 3 TUCK -> 1 3 2 3 }T 143 | 144 | T{ : RO5 100 200 300 400 500 ; -> }T 145 | T{ RO5 3 ROLL -> 100 300 400 500 200 }T 146 | T{ RO5 2 ROLL -> RO5 ROT }T 147 | T{ RO5 1 ROLL -> RO5 SWAP }T 148 | T{ RO5 0 ROLL -> RO5 }T 149 | 150 | T{ RO5 2 PICK -> 100 200 300 400 500 300 }T 151 | T{ RO5 1 PICK -> RO5 OVER }T 152 | T{ RO5 0 PICK -> RO5 DUP }T 153 | 154 | \ ----------------------------------------------------------------------------- 155 | TESTING 2>R 2R@ 2R> (contributed by James Bowman) 156 | 157 | T{ : RR0 2>R 100 R> R> ; -> }T 158 | T{ 300 400 RR0 -> 100 400 300 }T 159 | T{ 200 300 400 RR0 -> 200 100 400 300 }T 160 | 161 | T{ : RR1 2>R 100 2R@ R> R> ; -> }T 162 | T{ 300 400 RR1 -> 100 300 400 400 300 }T 163 | T{ 200 300 400 RR1 -> 200 100 300 400 400 300 }T 164 | 165 | T{ : RR2 2>R 100 2R> ; -> }T 166 | T{ 300 400 RR2 -> 100 300 400 }T 167 | T{ 200 300 400 RR2 -> 200 100 300 400 }T 168 | 169 | \ ----------------------------------------------------------------------------- 170 | TESTING HEX (contributed by James Bowman) 171 | 172 | T{ BASE @ HEX BASE @ DECIMAL BASE @ - SWAP BASE ! -> 6 }T 173 | 174 | \ ----------------------------------------------------------------------------- 175 | TESTING WITHIN (contributed by James Bowman) 176 | 177 | T{ 0 0 0 WITHIN -> FALSE }T 178 | T{ 0 0 MID-UINT WITHIN -> TRUE }T 179 | T{ 0 0 MID-UINT+1 WITHIN -> TRUE }T 180 | T{ 0 0 MAX-UINT WITHIN -> TRUE }T 181 | T{ 0 MID-UINT 0 WITHIN -> FALSE }T 182 | T{ 0 MID-UINT MID-UINT WITHIN -> FALSE }T 183 | T{ 0 MID-UINT MID-UINT+1 WITHIN -> FALSE }T 184 | T{ 0 MID-UINT MAX-UINT WITHIN -> FALSE }T 185 | T{ 0 MID-UINT+1 0 WITHIN -> FALSE }T 186 | T{ 0 MID-UINT+1 MID-UINT WITHIN -> TRUE }T 187 | T{ 0 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T 188 | T{ 0 MID-UINT+1 MAX-UINT WITHIN -> FALSE }T 189 | T{ 0 MAX-UINT 0 WITHIN -> FALSE }T 190 | T{ 0 MAX-UINT MID-UINT WITHIN -> TRUE }T 191 | T{ 0 MAX-UINT MID-UINT+1 WITHIN -> TRUE }T 192 | T{ 0 MAX-UINT MAX-UINT WITHIN -> FALSE }T 193 | T{ MID-UINT 0 0 WITHIN -> FALSE }T 194 | T{ MID-UINT 0 MID-UINT WITHIN -> FALSE }T 195 | T{ MID-UINT 0 MID-UINT+1 WITHIN -> TRUE }T 196 | T{ MID-UINT 0 MAX-UINT WITHIN -> TRUE }T 197 | T{ MID-UINT MID-UINT 0 WITHIN -> TRUE }T 198 | T{ MID-UINT MID-UINT MID-UINT WITHIN -> FALSE }T 199 | T{ MID-UINT MID-UINT MID-UINT+1 WITHIN -> TRUE }T 200 | T{ MID-UINT MID-UINT MAX-UINT WITHIN -> TRUE }T 201 | T{ MID-UINT MID-UINT+1 0 WITHIN -> FALSE }T 202 | T{ MID-UINT MID-UINT+1 MID-UINT WITHIN -> FALSE }T 203 | T{ MID-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T 204 | T{ MID-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T 205 | T{ MID-UINT MAX-UINT 0 WITHIN -> FALSE }T 206 | T{ MID-UINT MAX-UINT MID-UINT WITHIN -> FALSE }T 207 | T{ MID-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T 208 | T{ MID-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T 209 | T{ MID-UINT+1 0 0 WITHIN -> FALSE }T 210 | T{ MID-UINT+1 0 MID-UINT WITHIN -> FALSE }T 211 | T{ MID-UINT+1 0 MID-UINT+1 WITHIN -> FALSE }T 212 | T{ MID-UINT+1 0 MAX-UINT WITHIN -> TRUE }T 213 | T{ MID-UINT+1 MID-UINT 0 WITHIN -> TRUE }T 214 | T{ MID-UINT+1 MID-UINT MID-UINT WITHIN -> FALSE }T 215 | T{ MID-UINT+1 MID-UINT MID-UINT+1 WITHIN -> FALSE }T 216 | T{ MID-UINT+1 MID-UINT MAX-UINT WITHIN -> TRUE }T 217 | T{ MID-UINT+1 MID-UINT+1 0 WITHIN -> TRUE }T 218 | T{ MID-UINT+1 MID-UINT+1 MID-UINT WITHIN -> TRUE }T 219 | T{ MID-UINT+1 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T 220 | T{ MID-UINT+1 MID-UINT+1 MAX-UINT WITHIN -> TRUE }T 221 | T{ MID-UINT+1 MAX-UINT 0 WITHIN -> FALSE }T 222 | T{ MID-UINT+1 MAX-UINT MID-UINT WITHIN -> FALSE }T 223 | T{ MID-UINT+1 MAX-UINT MID-UINT+1 WITHIN -> FALSE }T 224 | T{ MID-UINT+1 MAX-UINT MAX-UINT WITHIN -> FALSE }T 225 | T{ MAX-UINT 0 0 WITHIN -> FALSE }T 226 | T{ MAX-UINT 0 MID-UINT WITHIN -> FALSE }T 227 | T{ MAX-UINT 0 MID-UINT+1 WITHIN -> FALSE }T 228 | T{ MAX-UINT 0 MAX-UINT WITHIN -> FALSE }T 229 | T{ MAX-UINT MID-UINT 0 WITHIN -> TRUE }T 230 | T{ MAX-UINT MID-UINT MID-UINT WITHIN -> FALSE }T 231 | T{ MAX-UINT MID-UINT MID-UINT+1 WITHIN -> FALSE }T 232 | T{ MAX-UINT MID-UINT MAX-UINT WITHIN -> FALSE }T 233 | T{ MAX-UINT MID-UINT+1 0 WITHIN -> TRUE }T 234 | T{ MAX-UINT MID-UINT+1 MID-UINT WITHIN -> TRUE }T 235 | T{ MAX-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T 236 | T{ MAX-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T 237 | T{ MAX-UINT MAX-UINT 0 WITHIN -> TRUE }T 238 | T{ MAX-UINT MAX-UINT MID-UINT WITHIN -> TRUE }T 239 | T{ MAX-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T 240 | T{ MAX-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T 241 | 242 | T{ MIN-INT MIN-INT MIN-INT WITHIN -> FALSE }T 243 | T{ MIN-INT MIN-INT 0 WITHIN -> TRUE }T 244 | T{ MIN-INT MIN-INT 1 WITHIN -> TRUE }T 245 | T{ MIN-INT MIN-INT MAX-INT WITHIN -> TRUE }T 246 | T{ MIN-INT 0 MIN-INT WITHIN -> FALSE }T 247 | T{ MIN-INT 0 0 WITHIN -> FALSE }T 248 | T{ MIN-INT 0 1 WITHIN -> FALSE }T 249 | T{ MIN-INT 0 MAX-INT WITHIN -> FALSE }T 250 | T{ MIN-INT 1 MIN-INT WITHIN -> FALSE }T 251 | T{ MIN-INT 1 0 WITHIN -> TRUE }T 252 | T{ MIN-INT 1 1 WITHIN -> FALSE }T 253 | T{ MIN-INT 1 MAX-INT WITHIN -> FALSE }T 254 | T{ MIN-INT MAX-INT MIN-INT WITHIN -> FALSE }T 255 | T{ MIN-INT MAX-INT 0 WITHIN -> TRUE }T 256 | T{ MIN-INT MAX-INT 1 WITHIN -> TRUE }T 257 | T{ MIN-INT MAX-INT MAX-INT WITHIN -> FALSE }T 258 | T{ 0 MIN-INT MIN-INT WITHIN -> FALSE }T 259 | T{ 0 MIN-INT 0 WITHIN -> FALSE }T 260 | T{ 0 MIN-INT 1 WITHIN -> TRUE }T 261 | T{ 0 MIN-INT MAX-INT WITHIN -> TRUE }T 262 | T{ 0 0 MIN-INT WITHIN -> TRUE }T 263 | T{ 0 0 0 WITHIN -> FALSE }T 264 | T{ 0 0 1 WITHIN -> TRUE }T 265 | T{ 0 0 MAX-INT WITHIN -> TRUE }T 266 | T{ 0 1 MIN-INT WITHIN -> FALSE }T 267 | T{ 0 1 0 WITHIN -> FALSE }T 268 | T{ 0 1 1 WITHIN -> FALSE }T 269 | T{ 0 1 MAX-INT WITHIN -> FALSE }T 270 | T{ 0 MAX-INT MIN-INT WITHIN -> FALSE }T 271 | T{ 0 MAX-INT 0 WITHIN -> FALSE }T 272 | T{ 0 MAX-INT 1 WITHIN -> TRUE }T 273 | T{ 0 MAX-INT MAX-INT WITHIN -> FALSE }T 274 | T{ 1 MIN-INT MIN-INT WITHIN -> FALSE }T 275 | T{ 1 MIN-INT 0 WITHIN -> FALSE }T 276 | T{ 1 MIN-INT 1 WITHIN -> FALSE }T 277 | T{ 1 MIN-INT MAX-INT WITHIN -> TRUE }T 278 | T{ 1 0 MIN-INT WITHIN -> TRUE }T 279 | T{ 1 0 0 WITHIN -> FALSE }T 280 | T{ 1 0 1 WITHIN -> FALSE }T 281 | T{ 1 0 MAX-INT WITHIN -> TRUE }T 282 | T{ 1 1 MIN-INT WITHIN -> TRUE }T 283 | T{ 1 1 0 WITHIN -> TRUE }T 284 | T{ 1 1 1 WITHIN -> FALSE }T 285 | T{ 1 1 MAX-INT WITHIN -> TRUE }T 286 | T{ 1 MAX-INT MIN-INT WITHIN -> FALSE }T 287 | T{ 1 MAX-INT 0 WITHIN -> FALSE }T 288 | T{ 1 MAX-INT 1 WITHIN -> FALSE }T 289 | T{ 1 MAX-INT MAX-INT WITHIN -> FALSE }T 290 | T{ MAX-INT MIN-INT MIN-INT WITHIN -> FALSE }T 291 | T{ MAX-INT MIN-INT 0 WITHIN -> FALSE }T 292 | T{ MAX-INT MIN-INT 1 WITHIN -> FALSE }T 293 | T{ MAX-INT MIN-INT MAX-INT WITHIN -> FALSE }T 294 | T{ MAX-INT 0 MIN-INT WITHIN -> TRUE }T 295 | T{ MAX-INT 0 0 WITHIN -> FALSE }T 296 | T{ MAX-INT 0 1 WITHIN -> FALSE }T 297 | T{ MAX-INT 0 MAX-INT WITHIN -> FALSE }T 298 | T{ MAX-INT 1 MIN-INT WITHIN -> TRUE }T 299 | T{ MAX-INT 1 0 WITHIN -> TRUE }T 300 | T{ MAX-INT 1 1 WITHIN -> FALSE }T 301 | T{ MAX-INT 1 MAX-INT WITHIN -> FALSE }T 302 | T{ MAX-INT MAX-INT MIN-INT WITHIN -> TRUE }T 303 | T{ MAX-INT MAX-INT 0 WITHIN -> TRUE }T 304 | T{ MAX-INT MAX-INT 1 WITHIN -> TRUE }T 305 | T{ MAX-INT MAX-INT MAX-INT WITHIN -> FALSE }T 306 | 307 | \ ----------------------------------------------------------------------------- 308 | TESTING UNUSED (contributed by James Bowman & Peter Knaggs) 309 | 310 | VARIABLE UNUSED0 311 | T{ UNUSED DROP -> }T 312 | T{ ALIGN UNUSED UNUSED0 ! 0 , UNUSED CELL+ UNUSED0 @ = -> TRUE }T 313 | T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = 314 | -> TRUE }T \ aligned -> unaligned 315 | T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = -> TRUE }T \ unaligned -> ? 316 | 317 | \ ----------------------------------------------------------------------------- 318 | TESTING AGAIN (contributed by James Bowman) 319 | 320 | T{ : AG0 701 BEGIN DUP 7 MOD 0= IF EXIT THEN 1+ AGAIN ; -> }T 321 | T{ AG0 -> 707 }T 322 | 323 | \ ----------------------------------------------------------------------------- 324 | TESTING MARKER (contributed by James Bowman) 325 | 326 | T{ : MA? BL WORD FIND NIP 0<> ; -> }T 327 | T{ MARKER MA0 -> }T 328 | T{ : MA1 111 ; -> }T 329 | T{ MARKER MA2 -> }T 330 | T{ : MA1 222 ; -> }T 331 | T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE TRUE }T 332 | T{ MA1 MA2 MA1 -> 222 111 }T 333 | T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE FALSE }T 334 | T{ MA0 -> }T 335 | T{ MA? MA0 MA? MA1 MA? MA2 -> FALSE FALSE FALSE }T 336 | 337 | \ ----------------------------------------------------------------------------- 338 | TESTING ?DO 339 | 340 | : QD ?DO I LOOP ; 341 | T{ 789 789 QD -> }T 342 | T{ -9876 -9876 QD -> }T 343 | T{ 5 0 QD -> 0 1 2 3 4 }T 344 | 345 | : QD1 ?DO I 10 +LOOP ; 346 | T{ 50 1 QD1 -> 1 11 21 31 41 }T 347 | T{ 50 0 QD1 -> 0 10 20 30 40 }T 348 | 349 | : QD2 ?DO I 3 > IF LEAVE ELSE I THEN LOOP ; 350 | T{ 5 -1 QD2 -> -1 0 1 2 3 }T 351 | 352 | : QD3 ?DO I 1 +LOOP ; 353 | T{ 4 4 QD3 -> }T 354 | T{ 4 1 QD3 -> 1 2 3 }T 355 | T{ 2 -1 QD3 -> -1 0 1 }T 356 | 357 | : QD4 ?DO I -1 +LOOP ; 358 | T{ 4 4 QD4 -> }T 359 | T{ 1 4 QD4 -> 4 3 2 1 }T 360 | T{ -1 2 QD4 -> 2 1 0 -1 }T 361 | 362 | : QD5 ?DO I -10 +LOOP ; 363 | T{ 1 50 QD5 -> 50 40 30 20 10 }T 364 | T{ 0 50 QD5 -> 50 40 30 20 10 0 }T 365 | T{ -25 10 QD5 -> 10 0 -10 -20 }T 366 | 367 | VARIABLE ITERS 368 | VARIABLE INCRMNT 369 | 370 | : QD6 ( limit start increment -- ) 371 | INCRMNT ! 372 | 0 ITERS ! 373 | ?DO 374 | 1 ITERS +! 375 | I 376 | ITERS @ 6 = IF LEAVE THEN 377 | INCRMNT @ 378 | +LOOP ITERS @ 379 | ; 380 | 381 | T{ 4 4 -1 QD6 -> 0 }T 382 | T{ 1 4 -1 QD6 -> 4 3 2 1 4 }T 383 | T{ 4 1 -1 QD6 -> 1 0 -1 -2 -3 -4 6 }T 384 | T{ 4 1 0 QD6 -> 1 1 1 1 1 1 6 }T 385 | T{ 0 0 0 QD6 -> 0 }T 386 | T{ 1 4 0 QD6 -> 4 4 4 4 4 4 6 }T 387 | T{ 1 4 1 QD6 -> 4 5 6 7 8 9 6 }T 388 | T{ 4 1 1 QD6 -> 1 2 3 3 }T 389 | T{ 4 4 1 QD6 -> 0 }T 390 | T{ 2 -1 -1 QD6 -> -1 -2 -3 -4 -5 -6 6 }T 391 | T{ -1 2 -1 QD6 -> 2 1 0 -1 4 }T 392 | T{ 2 -1 0 QD6 -> -1 -1 -1 -1 -1 -1 6 }T 393 | T{ -1 2 0 QD6 -> 2 2 2 2 2 2 6 }T 394 | T{ -1 2 1 QD6 -> 2 3 4 5 6 7 6 }T 395 | T{ 2 -1 1 QD6 -> -1 0 1 3 }T 396 | 397 | \ ----------------------------------------------------------------------------- 398 | TESTING BUFFER: 399 | 400 | T{ 8 BUFFER: BUF:TEST -> }T 401 | T{ BUF:TEST DUP ALIGNED = -> TRUE }T 402 | T{ 111 BUF:TEST ! 222 BUF:TEST CELL+ ! -> }T 403 | T{ BUF:TEST @ BUF:TEST CELL+ @ -> 111 222 }T 404 | 405 | \ ----------------------------------------------------------------------------- 406 | TESTING VALUE TO 407 | 408 | T{ 111 VALUE VAL1 -999 VALUE VAL2 -> }T 409 | T{ VAL1 -> 111 }T 410 | T{ VAL2 -> -999 }T 411 | T{ 222 TO VAL1 -> }T 412 | T{ VAL1 -> 222 }T 413 | T{ : VD1 VAL1 ; -> }T 414 | T{ VD1 -> 222 }T 415 | T{ : VD2 TO VAL2 ; -> }T 416 | T{ VAL2 -> -999 }T 417 | T{ -333 VD2 -> }T 418 | T{ VAL2 -> -333 }T 419 | T{ VAL1 -> 222 }T 420 | T{ 123 VALUE VAL3 IMMEDIATE VAL3 -> 123 }T 421 | T{ : VD3 VAL3 LITERAL ; VD3 -> 123 }T 422 | 423 | \ ----------------------------------------------------------------------------- 424 | TESTING CASE OF ENDOF ENDCASE 425 | 426 | : CS1 CASE 1 OF 111 ENDOF 427 | 2 OF 222 ENDOF 428 | 3 OF 333 ENDOF 429 | >R 999 R> 430 | ENDCASE 431 | ; 432 | 433 | T{ 1 CS1 -> 111 }T 434 | T{ 2 CS1 -> 222 }T 435 | T{ 3 CS1 -> 333 }T 436 | T{ 4 CS1 -> 999 }T 437 | 438 | \ Nested CASE's 439 | 440 | : CS2 >R CASE -1 OF CASE R@ 1 OF 100 ENDOF 441 | 2 OF 200 ENDOF 442 | >R -300 R> 443 | ENDCASE 444 | ENDOF 445 | -2 OF CASE R@ 1 OF -99 ENDOF 446 | >R -199 R> 447 | ENDCASE 448 | ENDOF 449 | >R 299 R> 450 | ENDCASE R> DROP 451 | ; 452 | 453 | T{ -1 1 CS2 -> 100 }T 454 | T{ -1 2 CS2 -> 200 }T 455 | T{ -1 3 CS2 -> -300 }T 456 | T{ -2 1 CS2 -> -99 }T 457 | T{ -2 2 CS2 -> -199 }T 458 | T{ 0 2 CS2 -> 299 }T 459 | 460 | \ Boolean short circuiting using CASE 461 | 462 | : CS3 ( N1 -- N2 ) 463 | CASE 1- FALSE OF 11 ENDOF 464 | 1- FALSE OF 22 ENDOF 465 | 1- FALSE OF 33 ENDOF 466 | 44 SWAP 467 | ENDCASE 468 | ; 469 | 470 | T{ 1 CS3 -> 11 }T 471 | T{ 2 CS3 -> 22 }T 472 | T{ 3 CS3 -> 33 }T 473 | T{ 9 CS3 -> 44 }T 474 | 475 | \ Empty CASE statements with/without default 476 | 477 | T{ : CS4 CASE ENDCASE ; 1 CS4 -> }T 478 | T{ : CS5 CASE 2 SWAP ENDCASE ; 1 CS5 -> 2 }T 479 | T{ : CS6 CASE 1 OF ENDOF 2 ENDCASE ; 1 CS6 -> }T 480 | T{ : CS7 CASE 3 OF ENDOF 2 ENDCASE ; 1 CS7 -> 1 }T 481 | 482 | \ ----------------------------------------------------------------------------- 483 | TESTING :NONAME RECURSE 484 | 485 | VARIABLE NN1 486 | VARIABLE NN2 487 | :NONAME 1234 ; NN1 ! 488 | :NONAME 9876 ; NN2 ! 489 | T{ NN1 @ EXECUTE -> 1234 }T 490 | T{ NN2 @ EXECUTE -> 9876 }T 491 | 492 | T{ :NONAME ( n -- 0,1,..n ) DUP IF DUP >R 1- RECURSE R> THEN ; 493 | CONSTANT RN1 -> }T 494 | T{ 0 RN1 EXECUTE -> 0 }T 495 | T{ 4 RN1 EXECUTE -> 0 1 2 3 4 }T 496 | 497 | :NONAME ( n -- n1 ) \ Multiple RECURSEs in one definition 498 | 1- DUP 499 | CASE 0 OF EXIT ENDOF 500 | 1 OF 11 SWAP RECURSE ENDOF 501 | 2 OF 22 SWAP RECURSE ENDOF 502 | 3 OF 33 SWAP RECURSE ENDOF 503 | DROP ABS RECURSE EXIT 504 | ENDCASE 505 | ; CONSTANT RN2 506 | 507 | T{ 1 RN2 EXECUTE -> 0 }T 508 | T{ 2 RN2 EXECUTE -> 11 0 }T 509 | T{ 4 RN2 EXECUTE -> 33 22 11 0 }T 510 | T{ 25 RN2 EXECUTE -> 33 22 11 0 }T 511 | 512 | \ ----------------------------------------------------------------------------- 513 | TESTING C" 514 | 515 | T{ : CQ1 C" 123" ; -> }T 516 | T{ CQ1 COUNT EVALUATE -> 123 }T 517 | T{ : CQ2 C" " ; -> }T 518 | T{ CQ2 COUNT EVALUATE -> }T 519 | T{ : CQ3 C" 2345"COUNT EVALUATE ; CQ3 -> 2345 }T 520 | 521 | \ ----------------------------------------------------------------------------- 522 | TESTING COMPILE, 523 | 524 | :NONAME DUP + ; CONSTANT DUP+ 525 | T{ : Q DUP+ COMPILE, ; -> }T 526 | T{ : AS1 [ Q ] ; -> }T 527 | T{ 123 AS1 -> 246 }T 528 | 529 | \ ----------------------------------------------------------------------------- 530 | \ Cannot automatically test SAVE-INPUT and RESTORE-INPUT from a console source 531 | 532 | TESTING SAVE-INPUT and RESTORE-INPUT with a string source 533 | 534 | VARIABLE SI_INC 0 SI_INC ! 535 | 536 | : SI1 537 | SI_INC @ >IN +! 538 | 15 SI_INC ! 539 | ; 540 | 541 | : S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ; 542 | 543 | T{ S$ EVALUATE SI_INC @ -> 0 2345 15 }T 544 | 545 | \ ----------------------------------------------------------------------------- 546 | TESTING .( 547 | 548 | CR CR .( Output from .() 549 | T{ CR .( You should see -9876: ) -9876 . -> }T 550 | T{ CR .( and again: ).( -9876)CR -> }T 551 | 552 | CR CR .( On the next 2 lines you should see First then Second messages:) 553 | T{ : DOTP CR ." Second message via ." [CHAR] " EMIT \ Check .( is immediate 554 | [ CR ] .( First message via .( ) ; DOTP -> }T 555 | CR CR 556 | T{ : IMM? BL WORD FIND NIP ; IMM? .( -> 1 }T 557 | 558 | \ ----------------------------------------------------------------------------- 559 | TESTING .R and U.R - has to handle different cell sizes 560 | 561 | \ Create some large integers just below/above MAX and Min INTs 562 | MAX-INT 73 79 */ CONSTANT LI1 563 | MIN-INT 71 73 */ CONSTANT LI2 564 | 565 | LI1 0 <# #S #> NIP CONSTANT LENLI1 566 | 567 | : (.R&U.R) ( u1 u2 -- ) \ u1 <= string length, u2 is required indentation 568 | TUCK + >R 569 | LI1 OVER SPACES . CR R@ LI1 SWAP .R CR 570 | LI2 OVER SPACES . CR R@ 1+ LI2 SWAP .R CR 571 | LI1 OVER SPACES U. CR R@ LI1 SWAP U.R CR 572 | LI2 SWAP SPACES U. CR R> LI2 SWAP U.R CR 573 | ; 574 | 575 | : .R&U.R ( -- ) 576 | CR ." You should see lines duplicated:" CR 577 | ." indented by 0 spaces" CR 0 0 (.R&U.R) CR 578 | ." indented by 0 spaces" CR LENLI1 0 (.R&U.R) CR \ Just fits required width 579 | ." indented by 5 spaces" CR LENLI1 5 (.R&U.R) CR 580 | ; 581 | 582 | CR CR .( Output from .R and U.R) 583 | T{ .R&U.R -> }T 584 | 585 | \ ----------------------------------------------------------------------------- 586 | TESTING PAD ERASE 587 | \ Must handle different size characters i.e. 1 CHARS >= 1 588 | 589 | 84 CONSTANT CHARS/PAD \ Minimum size of PAD in chars 590 | CHARS/PAD CHARS CONSTANT AUS/PAD 591 | : CHECKPAD ( caddr u ch -- f ) \ f = TRUE if u chars = ch 592 | SWAP 0 593 | ?DO 594 | OVER I CHARS + C@ OVER <> 595 | IF 2DROP UNLOOP FALSE EXIT THEN 596 | LOOP 597 | 2DROP TRUE 598 | ; 599 | 600 | T{ PAD DROP -> }T 601 | T{ 0 INVERT PAD C! -> }T 602 | T{ PAD C@ CONSTANT MAXCHAR -> }T 603 | T{ PAD CHARS/PAD 2DUP MAXCHAR FILL MAXCHAR CHECKPAD -> TRUE }T 604 | T{ PAD CHARS/PAD 2DUP CHARS ERASE 0 CHECKPAD -> TRUE }T 605 | T{ PAD CHARS/PAD 2DUP MAXCHAR FILL PAD 0 ERASE MAXCHAR CHECKPAD -> TRUE }T 606 | T{ PAD 43 CHARS + 9 CHARS ERASE -> }T 607 | T{ PAD 43 MAXCHAR CHECKPAD -> TRUE }T 608 | T{ PAD 43 CHARS + 9 0 CHECKPAD -> TRUE }T 609 | T{ PAD 52 CHARS + CHARS/PAD 52 - MAXCHAR CHECKPAD -> TRUE }T 610 | 611 | \ Check that use of WORD and pictured numeric output do not corrupt PAD 612 | \ Minimum size of buffers for these are 33 chars and (2*n)+2 chars respectively 613 | \ where n is number of bits per cell 614 | 615 | PAD CHARS/PAD ERASE 616 | 2 BASE ! 617 | MAX-UINT MAX-UINT <# #S CHAR 1 DUP HOLD HOLD #> 2DROP 618 | DECIMAL 619 | BL WORD 12345678123456781234567812345678 DROP 620 | T{ PAD CHARS/PAD 0 CHECKPAD -> TRUE }T 621 | 622 | \ ----------------------------------------------------------------------------- 623 | TESTING PARSE 624 | 625 | T{ CHAR | PARSE 1234| DUP ROT ROT EVALUATE -> 4 1234 }T 626 | T{ CHAR ^ PARSE 23 45 ^ DUP ROT ROT EVALUATE -> 7 23 45 }T 627 | : PA1 [CHAR] $ PARSE DUP >R PAD SWAP CHARS MOVE PAD R> ; 628 | T{ PA1 3456 629 | DUP ROT ROT EVALUATE -> 4 3456 }T 630 | T{ CHAR A PARSE A SWAP DROP -> 0 }T 631 | T{ CHAR Z PARSE 632 | SWAP DROP -> 0 }T 633 | T{ CHAR " PARSE 4567 "DUP ROT ROT EVALUATE -> 5 4567 }T 634 | 635 | \ ----------------------------------------------------------------------------- 636 | TESTING PARSE-NAME (Forth 2012) 637 | \ Adapted from the PARSE-NAME RfD tests 638 | 639 | T{ PARSE-NAME abcd STR1 S= -> TRUE }T \ No leading spaces 640 | T{ PARSE-NAME abcde STR2 S= -> TRUE }T \ Leading spaces 641 | 642 | \ Test empty parse area, new lines are necessary 643 | T{ PARSE-NAME 644 | NIP -> 0 }T 645 | \ Empty parse area with spaces after PARSE-NAME 646 | T{ PARSE-NAME 647 | NIP -> 0 }T 648 | 649 | T{ : PARSE-NAME-TEST ( "name1" "name2" -- n ) 650 | PARSE-NAME PARSE-NAME S= ; -> }T 651 | T{ PARSE-NAME-TEST abcd abcd -> TRUE }T 652 | T{ PARSE-NAME-TEST abcd abcd -> TRUE }T \ Leading spaces 653 | T{ PARSE-NAME-TEST abcde abcdf -> FALSE }T 654 | T{ PARSE-NAME-TEST abcdf abcde -> FALSE }T 655 | T{ PARSE-NAME-TEST abcde abcde 656 | -> TRUE }T \ Parse to end of line 657 | T{ PARSE-NAME-TEST abcde abcde 658 | -> TRUE }T \ Leading and trailing spaces 659 | 660 | \ ----------------------------------------------------------------------------- 661 | TESTING DEFER DEFER@ DEFER! IS ACTION-OF (Forth 2012) 662 | \ Adapted from the Forth 200X RfD tests 663 | 664 | T{ DEFER DEFER1 -> }T 665 | T{ : MY-DEFER DEFER ; -> }T 666 | T{ : IS-DEFER1 IS DEFER1 ; -> }T 667 | T{ : ACTION-DEFER1 ACTION-OF DEFER1 ; -> }T 668 | T{ : DEF! DEFER! ; -> }T 669 | T{ : DEF@ DEFER@ ; -> }T 670 | 671 | T{ ' * ' DEFER1 DEFER! -> }T 672 | T{ 2 3 DEFER1 -> 6 }T 673 | T{ ' DEFER1 DEFER@ -> ' * }T 674 | T{ ' DEFER1 DEF@ -> ' * }T 675 | T{ ACTION-OF DEFER1 -> ' * }T 676 | T{ ACTION-DEFER1 -> ' * }T 677 | T{ ' + IS DEFER1 -> }T 678 | T{ 1 2 DEFER1 -> 3 }T 679 | T{ ' DEFER1 DEFER@ -> ' + }T 680 | T{ ' DEFER1 DEF@ -> ' + }T 681 | T{ ACTION-OF DEFER1 -> ' + }T 682 | T{ ACTION-DEFER1 -> ' + }T 683 | T{ ' - IS-DEFER1 -> }T 684 | T{ 1 2 DEFER1 -> -1 }T 685 | T{ ' DEFER1 DEFER@ -> ' - }T 686 | T{ ' DEFER1 DEF@ -> ' - }T 687 | T{ ACTION-OF DEFER1 -> ' - }T 688 | T{ ACTION-DEFER1 -> ' - }T 689 | 690 | T{ MY-DEFER DEFER2 -> }T 691 | T{ ' DUP IS DEFER2 -> }T 692 | T{ 1 DEFER2 -> 1 1 }T 693 | 694 | \ ----------------------------------------------------------------------------- 695 | TESTING HOLDS (Forth 2012) 696 | 697 | : HTEST S" Testing HOLDS" ; 698 | : HTEST2 S" works" ; 699 | : HTEST3 S" Testing HOLDS works 123" ; 700 | T{ 0 0 <# HTEST HOLDS #> HTEST S= -> TRUE }T 701 | T{ 123 0 <# #S BL HOLD HTEST2 HOLDS BL HOLD HTEST HOLDS #> 702 | HTEST3 S= -> TRUE }T 703 | T{ : HLD HOLDS ; -> }T 704 | T{ 0 0 <# HTEST HLD #> HTEST S= -> TRUE }T 705 | 706 | \ ----------------------------------------------------------------------------- 707 | TESTING REFILL SOURCE-ID 708 | \ REFILL and SOURCE-ID from the user input device can't be tested from a file, 709 | \ can only be tested from a string via EVALUATE 710 | 711 | T{ : RF1 S" REFILL" EVALUATE ; RF1 -> FALSE }T 712 | T{ : SID1 S" SOURCE-ID" EVALUATE ; SID1 -> -1 }T 713 | 714 | \ ------------------------------------------------------------------------------ 715 | TESTING S\" (Forth 2012 compilation mode) 716 | \ Extended the Forth 200X RfD tests 717 | \ Note this tests the Core Ext definition of S\" which has unedfined 718 | \ interpretation semantics. S\" in interpretation mode is tested in the tests on 719 | \ the File-Access word set 720 | 721 | T{ : SSQ1 S\" abc" S" abc" S= ; -> }T \ No escapes 722 | T{ SSQ1 -> TRUE }T 723 | T{ : SSQ2 S\" " ; SSQ2 SWAP DROP -> 0 }T \ Empty string 724 | 725 | T{ : SSQ3 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T 726 | T{ SSQ3 SWAP DROP -> 20 }T \ String length 727 | T{ SSQ3 DROP C@ -> 7 }T \ \a BEL Bell 728 | T{ SSQ3 DROP 1 CHARS + C@ -> 8 }T \ \b BS Backspace 729 | T{ SSQ3 DROP 2 CHARS + C@ -> 27 }T \ \e ESC Escape 730 | T{ SSQ3 DROP 3 CHARS + C@ -> 12 }T \ \f FF Form feed 731 | T{ SSQ3 DROP 4 CHARS + C@ -> 10 }T \ \l LF Line feed 732 | T{ SSQ3 DROP 5 CHARS + C@ -> 13 }T \ \m CR of CR/LF pair 733 | T{ SSQ3 DROP 6 CHARS + C@ -> 10 }T \ LF of CR/LF pair 734 | T{ SSQ3 DROP 7 CHARS + C@ -> 34 }T \ \q " Double Quote 735 | T{ SSQ3 DROP 8 CHARS + C@ -> 13 }T \ \r CR Carriage Return 736 | T{ SSQ3 DROP 9 CHARS + C@ -> 9 }T \ \t TAB Horizontal Tab 737 | T{ SSQ3 DROP 10 CHARS + C@ -> 11 }T \ \v VT Vertical Tab 738 | T{ SSQ3 DROP 11 CHARS + C@ -> 15 }T \ \x0F Given Char 739 | T{ SSQ3 DROP 12 CHARS + C@ -> 48 }T \ 0 0 Digit follow on 740 | T{ SSQ3 DROP 13 CHARS + C@ -> 31 }T \ \x1F Given Char 741 | T{ SSQ3 DROP 14 CHARS + C@ -> 97 }T \ a a Hex follow on 742 | T{ SSQ3 DROP 15 CHARS + C@ -> 171 }T \ \xaB Insensitive Given Char 743 | T{ SSQ3 DROP 16 CHARS + C@ -> 120 }T \ x x Non hex follow on 744 | T{ SSQ3 DROP 17 CHARS + C@ -> 0 }T \ \z NUL No Character 745 | T{ SSQ3 DROP 18 CHARS + C@ -> 34 }T \ \" " Double Quote 746 | T{ SSQ3 DROP 19 CHARS + C@ -> 92 }T \ \\ \ Back Slash 747 | 748 | \ The above does not test \n as this is a system dependent value. 749 | \ Check it displays a new line 750 | CR .( The next test should display:) 751 | CR .( One line...) 752 | CR .( another line) 753 | T{ : SSQ4 S\" \nOne line...\nanotherLine\n" type ; SSQ4 -> }T 754 | 755 | \ Test bare escapable characters appear as themselves 756 | T{ : SSQ5 S\" abeflmnqrtvxz" S" abeflmnqrtvxz" S= ; SSQ5 -> TRUE }T 757 | 758 | T{ : SSQ6 S\" a\""2DROP 1111 ; SSQ6 -> 1111 }T \ Parsing behaviour 759 | 760 | T{ : SSQ7 S\" 111 : SSQ8 s\\\" 222\" EVALUATE ; SSQ8 333" EVALUATE ; -> }T 761 | T{ SSQ7 -> 111 222 333 }T 762 | T{ : SSQ9 S\" 11 : SSQ10 s\\\" \\x32\\x32\" EVALUATE ; SSQ10 33" EVALUATE ; -> }T 763 | T{ SSQ9 -> 11 22 33 }T 764 | 765 | \ ----------------------------------------------------------------------------- 766 | CORE-EXT-ERRORS SET-ERROR-COUNT 767 | 768 | CR .( End of Core Extension word tests) CR 769 | 770 | 771 | 772 | -------------------------------------------------------------------------------- /src/words.fs: -------------------------------------------------------------------------------- 1 | variable base 10 base ! 2 | 3 | code 0 4 | lda #0 5 | tay 6 | jmp %pushya% 7 | ;code 8 | 1 constant 1 9 | 10 | : chars ; 11 | : char+ 1+ ; 12 | : align ; 13 | : aligned ; 14 | 15 | : negate invert 1+ ; 16 | : if postpone 0branch here 0 , ; immediate 17 | : begin here ; immediate 18 | 19 | variable end 20 | create hold-buffer 34 allot 21 | : <# hold-buffer end ! ; 22 | : #> 2drop hold-buffer end @ over - ; 23 | : hold 24 | hold-buffer dup 1+ end @ hold-buffer - move 25 | 1 end +! hold-buffer c! ; 26 | : sign 0< if '-' hold then ; 27 | : ud/mod 28 | >r 0 r@ um/mod r> swap >r um/mod r> ; 29 | : # base @ ud/mod rot 30 | dup $a < if 7 - then $37 + hold ; 31 | : #s # begin 2dup or while # repeat ; 32 | 33 | : i postpone r@ ; immediate 34 | : nip swap drop ; 35 | : \ refill 0= if source nip >in ! then ; immediate 36 | : 2r@ r> r> r> 2dup >r >r rot rot swap >r ; 37 | : 2>r r> rot rot swap >r >r >r ; 38 | : 2r> r> r> r> swap rot >r ; 39 | : u> swap u< ; 40 | : 2+ 1+ 1+ ; 41 | : cell+ 2+ ; 42 | : 2@ dup 2+ @ swap @ ; 43 | : 2! swap over ! 2+ ! ; 44 | : cells 2* ; 45 | : s>d dup 0< ; 46 | : min 2dup < if drop else nip then ; 47 | : max 2dup > if drop else nip then ; 48 | : ?dup dup if dup then ; 49 | : case 0 ; immediate 50 | : endcase postpone drop begin ?dup while postpone then repeat ; immediate 51 | : of postpone (of) here 0 , ; immediate 52 | : endof postpone else ; immediate 53 | : value create , does> @ ; \ TODO Optimized VALUE/TO, like DurexForth. 54 | : 0<> 0= 0= ; 55 | : 0> dup 0< 0= swap 0<> and ; 56 | : <> = 0= ; 57 | : buffer: create allot ; 58 | : hex $10 base ! ; 59 | : decimal #10 base ! ; 60 | : true -1 ; 61 | : false 0 ; 62 | : bl $20 ; 63 | : space bl emit ; 64 | : . s>d swap over dabs <# #s rot sign #> type space ; 65 | : u. 0 <# #s #> type space ; 66 | : save-input >in @ 1 ; 67 | : restore-input drop >in ! 0 ; 68 | : spaces begin dup 0> while space 1- repeat drop ; 69 | : .s ." <" depth s>d swap over dabs <# #s rot sign #> type ." > " 70 | depth 1+ 1 ?do depth i - pick . loop cr ; 71 | : .r ( n1 n2 -- ) 72 | swap s>d swap over dabs <# #s rot sign #> 73 | rot over - spaces type space ; 74 | : u.r ( u n -- ) 75 | swap 0 <# #s #> rot over - spaces type space ; 76 | create pad 84 allot 77 | : erase 0 fill ; 78 | : 2over 3 pick 3 pick ; 79 | : 2swap >r rot rot r> rot rot ; 80 | : [ 0 state ! ; immediate 81 | : ] -1 state ! ; 82 | : count dup 1+ swap c@ ; 83 | : /string dup >r - swap r> + swap ; 84 | : abort depth 0 ?do drop loop quit ; 85 | : abort" postpone if postpone ." postpone cr postpone abort postpone then ; immediate 86 | : within over - >r - r> u< ; \ forth-standard.org 87 | : roll ?dup if swap >r 1- recurse r> swap then ; 88 | 89 | \ from test suite 90 | : S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. 91 | >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH 92 | R> ?DUP IF \ IF NON-EMPTY STRINGS 93 | 0 DO 94 | OVER C@ OVER C@ - IF 2DROP FALSE UNLOOP EXIT THEN 95 | SWAP CHAR+ SWAP CHAR+ 96 | LOOP 97 | THEN 98 | 2DROP TRUE \ IF WE GET HERE, STRINGS MATCH 99 | ELSE 100 | R> DROP 2DROP FALSE \ LENGTHS MISMATCH 101 | THEN ; 102 | 103 | : m+ s>d d+ ; 104 | : dnegate invert >r invert r> 1 m+ ; 105 | 106 | : fm/mod \ from Gforth 107 | dup >r dup 0< if negate >r dnegate r> then 108 | over 0< if tuck + swap then um/mod 109 | r> 0< if swap negate swap then ; 110 | 111 | ( from FIG UK ) 112 | : /mod >r s>d r> fm/mod ; 113 | : / /mod nip ; 114 | : mod /mod drop ; 115 | : */mod >r m* r> fm/mod ; 116 | : */ */mod nip ; 117 | : ?negate 0< if negate then ; 118 | : sm/rem 2dup xor >r over >r abs >r dabs r> um/mod swap r> ?negate swap r> ?negate ; 119 | 120 | ( from forth-standard.org ) 121 | : isspace? BL 1+ U< ; 122 | : isnotspace? isspace? 0= ; 123 | : xt-skip >R BEGIN DUP WHILE OVER C@ R@ EXECUTE WHILE 1 /STRING REPEAT THEN R> DROP ; 124 | : parse-name SOURCE >IN @ /STRING ['] isspace? xt-skip OVER >R ['] isnotspace? xt-skip 2DUP 1 MIN + SOURCE DROP - >IN ! DROP R> TUCK - ; 125 | : DEFER CREATE ['] ABORT , DOES> @ EXECUTE ; 126 | : defer! >body ! ; 127 | : defer@ >body @ ; 128 | : ACTION-OF STATE @ IF POSTPONE ['] POSTPONE DEFER@ ELSE ' DEFER@ THEN ; IMMEDIATE 129 | : IS STATE @ IF POSTPONE ['] POSTPONE DEFER! ELSE ' DEFER! THEN ; IMMEDIATE 130 | : HOLDS BEGIN DUP WHILE 1- 2DUP + C@ HOLD REPEAT 2DROP ; 131 | 132 | code d+ ; ( d1 d2 -- d3 ) 133 | clc 134 | lda LSB+1,x 135 | adc LSB+3,x 136 | sta LSB+3,x 137 | lda MSB+1,x 138 | adc MSB+3,x 139 | sta MSB+3,x 140 | lda LSB,x 141 | adc LSB+2,x 142 | sta LSB+2,x 143 | lda MSB,x 144 | adc MSB+2,x 145 | sta MSB+2,x 146 | inx 147 | inx 148 | rts 149 | ;code 150 | 151 | : accumulate ( +d0 addr digit - +d1 addr ) 152 | swap >r swap base @ um* drop 153 | rot base @ um* d+ r> ; 154 | : pet# ( char -- num ) 155 | $7f and dup \ lowercase 156 | ':' < if '0' else '7' then - ; 157 | : digit? ( char -- flag ) 158 | pet# dup 0< 0= swap base @ < and ; 159 | : >number ( ud addr u -- ud addr u ) 160 | begin dup 0= if exit then 161 | over c@ digit? while 162 | >r dup c@ pet# accumulate 163 | 1+ r> 1- repeat ; 164 | 165 | \ ----- C64 primitives below 166 | 167 | code c@ 168 | lda LSB,x 169 | sta + + 1 170 | lda MSB,x 171 | sta + + 2 172 | + lda $cafe 173 | sta LSB,x 174 | lda #0 175 | sta MSB,x 176 | rts 177 | ;code 178 | 179 | code c! 180 | lda LSB,x 181 | sta + + 1 182 | lda MSB,x 183 | sta + + 2 184 | lda LSB+1,x 185 | + sta $1234 186 | inx 187 | inx 188 | rts 189 | ;code 190 | 191 | code 1+ 192 | inc LSB, x 193 | bne + 194 | inc MSB, x 195 | + rts 196 | ;code 197 | 198 | code litc 199 | dex 200 | 201 | ; load IP 202 | pla 203 | sta W 204 | pla 205 | sta W + 1 206 | 207 | inc W 208 | bne + 209 | inc W + 1 210 | + 211 | ; copy literal to stack 212 | ldy #0 213 | lda (W), y 214 | sta LSB, x 215 | sty MSB, x 216 | 217 | inc W 218 | bne + 219 | inc W + 1 220 | + jmp (W) 221 | ;code 222 | 223 | code lit 224 | dex 225 | 226 | ; load IP 227 | pla 228 | sta W 229 | pla 230 | sta W + 1 231 | 232 | ; copy literal to stack 233 | ldy #1 234 | lda (W), y 235 | sta LSB, x 236 | iny 237 | lda (W), y 238 | sta MSB, x 239 | 240 | lda W 241 | clc 242 | adc #3 243 | sta + + 1 244 | lda W + 1 245 | adc #0 246 | sta + + 2 247 | + jmp $1234 248 | ;code 249 | 250 | code (loop) 251 | stx W ; x = stack pointer 252 | tsx 253 | 254 | inc $103,x ; i++ 255 | bne + 256 | inc $104,x 257 | + 258 | lda $103,x ; lsb check 259 | cmp $105,x 260 | beq .check_msb 261 | 262 | .continue_loop 263 | ldx W ; restore x 264 | jmp %branch% 265 | 266 | .check_msb 267 | lda $104,x 268 | cmp $106,x 269 | bne .continue_loop 270 | 271 | pla ; loop done - skip branch address 272 | clc 273 | adc #3 274 | sta W2 275 | 276 | pla 277 | adc #0 278 | sta W2 + 1 279 | 280 | txa ; sp += 6 281 | clc 282 | adc #6 283 | tax 284 | txs 285 | 286 | ldx W ; restore x 287 | jmp (W2) 288 | ;code 289 | 290 | code 0branch 291 | inx 292 | lda LSB-1, x 293 | ora MSB-1, x 294 | bne + 295 | jmp %branch% 296 | + ; skip offset 297 | pla 298 | clc 299 | adc #2 300 | bcc + 301 | tay 302 | pla 303 | adc #0 304 | pha 305 | tya 306 | + pha 307 | rts 308 | ;code 309 | 310 | code ! 311 | lda LSB, x 312 | sta W 313 | lda MSB, x 314 | sta W + 1 315 | 316 | ldy #0 317 | lda LSB+1, x 318 | sta (W), y 319 | iny 320 | lda MSB+1, x 321 | sta (W), y 322 | 323 | inx 324 | inx 325 | rts 326 | ;code 327 | 328 | code 0< 329 | lda MSB,x 330 | and #$80 331 | beq + 332 | lda #$ff 333 | + sta LSB,x 334 | sta MSB,x 335 | rts 336 | ;code 337 | 338 | code dup 339 | dex 340 | lda MSB + 1, x 341 | sta MSB, x 342 | lda LSB + 1, x 343 | sta LSB, x 344 | rts 345 | ;code 346 | 347 | code type 348 | - lda LSB,x 349 | ora MSB,x 350 | bne + 351 | inx 352 | inx 353 | rts 354 | + jsr %over% 355 | jsr %c@% 356 | jsr %emit% 357 | jsr %1% 358 | jsr %/string% 359 | jmp - 360 | ;code 361 | 362 | code depth 363 | txa 364 | eor #$ff 365 | tay 366 | iny 367 | dex 368 | sty LSB,x 369 | lda #0 370 | sta MSB,x 371 | rts 372 | ;code 373 | 374 | code @ 375 | lda LSB,x 376 | sta W 377 | lda MSB,x 378 | sta W+1 379 | 380 | ldy #0 381 | lda (W),y 382 | sta LSB,x 383 | iny 384 | lda (W),y 385 | sta MSB,x 386 | rts 387 | ;code 388 | 389 | code = 390 | ldy #0 391 | lda LSB, x 392 | cmp LSB + 1, x 393 | bne + 394 | lda MSB, x 395 | cmp MSB + 1, x 396 | bne + 397 | dey 398 | + inx 399 | sty MSB, x 400 | sty LSB, x 401 | rts 402 | ;code 403 | 404 | code (do) 405 | pla 406 | sta W 407 | pla 408 | tay 409 | 410 | lda MSB+1,x 411 | pha 412 | lda LSB+1,x 413 | pha 414 | 415 | lda MSB,x 416 | pha 417 | lda LSB,x 418 | pha 419 | 420 | inx 421 | inx 422 | 423 | tya 424 | pha 425 | lda W 426 | pha 427 | rts 428 | ;code 429 | 430 | code j 431 | txa 432 | tsx 433 | ldy $107,x 434 | sty W 435 | ldy $108,x 436 | tax 437 | dex 438 | sty MSB,x 439 | lda W 440 | sta LSB,x 441 | rts 442 | ;code 443 | 444 | code + 445 | lda LSB, x 446 | clc 447 | adc LSB + 1, x 448 | sta LSB + 1, x 449 | 450 | lda MSB, x 451 | adc MSB + 1, x 452 | sta MSB + 1, x 453 | 454 | inx 455 | rts 456 | ;code 457 | 458 | code 0= 459 | ldy #0 460 | lda MSB, x 461 | bne + 462 | lda LSB, x 463 | bne + 464 | dey 465 | + sty MSB, x 466 | sty LSB, x 467 | rts 468 | ;code 469 | 470 | code sliteral 471 | jsr %r>% 472 | jsr %1+% 473 | jsr %dup% 474 | jsr %1+% 475 | jsr %swap% 476 | jsr %c@% 477 | jsr %2dup% 478 | jsr %+% 479 | jsr %1-% 480 | jsr %>r% 481 | rts 482 | ;code 483 | 484 | code 1- 485 | lda LSB, x 486 | bne + 487 | dec MSB, x 488 | + dec LSB, x 489 | rts 490 | ;code 491 | 492 | code 2dup 493 | jsr %over% 494 | jmp %over% 495 | ;code 496 | 497 | code over 498 | dex 499 | lda MSB + 2, x 500 | sta MSB, x 501 | lda LSB + 2, x 502 | sta LSB, x 503 | rts 504 | ;code 505 | 506 | code swap 507 | ldy MSB, x 508 | lda MSB + 1, x 509 | sta MSB, x 510 | sty MSB + 1, x 511 | 512 | ldy LSB, x 513 | lda LSB + 1, x 514 | sta LSB, x 515 | sty LSB + 1, x 516 | rts 517 | ;code 518 | 519 | code cr 520 | jsr %litc% 521 | !byte $d 522 | jmp %emit% 523 | ;code 524 | 525 | code emit 526 | lda LSB, x 527 | inx 528 | jmp PUTCHR 529 | ;code 530 | 531 | code /string 532 | jsr %dup% 533 | jsr %>r% 534 | jsr %-% 535 | jsr %swap% 536 | jsr %r>% 537 | jsr %+% 538 | jmp %swap% 539 | ;code 540 | 541 | code - 542 | lda LSB + 1, x 543 | sec 544 | sbc LSB, x 545 | sta LSB + 1, x 546 | lda MSB + 1, x 547 | sbc MSB, x 548 | sta MSB + 1, x 549 | inx 550 | rts 551 | ;code 552 | 553 | code pushya 554 | dex 555 | sta LSB, x 556 | sty MSB, x 557 | rts 558 | ;code 559 | 560 | code invert 561 | lda MSB, x 562 | eor #$ff 563 | sta MSB, x 564 | lda LSB, x 565 | eor #$ff 566 | sta LSB,x 567 | rts 568 | ;code 569 | 570 | code branch 571 | pla 572 | sta W 573 | pla 574 | sta W + 1 575 | 576 | ldy #2 577 | lda (W), y 578 | sta + + 2 579 | dey 580 | lda (W), y 581 | sta + + 1 582 | + jmp $1234 583 | ;code 584 | 585 | code dabs 586 | jsr %dup% 587 | jmp %?dnegate% 588 | ;code 589 | 590 | code ?dnegate 591 | jsr %0<% 592 | inx 593 | lda MSB-1,x 594 | beq + 595 | jsr %dnegate% 596 | + rts 597 | ;code 598 | 599 | code +! 600 | lda LSB,x 601 | sta W 602 | lda MSB,x 603 | sta W+1 604 | 605 | ldy #0 606 | clc 607 | 608 | lda (W),y 609 | adc LSB+1,x 610 | sta (W),y 611 | iny 612 | lda (W),y 613 | adc MSB+1,x 614 | sta (W),y 615 | inx 616 | inx 617 | rts 618 | ;code 619 | 620 | code 2* 621 | asl LSB, x 622 | rol MSB, x 623 | rts 624 | ;code 625 | 626 | code 2/ 627 | lda MSB,x 628 | cmp #$80 629 | ror MSB,x 630 | ror LSB,x 631 | rts 632 | ;code 633 | 634 | code and 635 | lda MSB, x 636 | and MSB + 1, x 637 | sta MSB + 1, x 638 | 639 | lda LSB, x 640 | and LSB + 1, x 641 | sta LSB + 1, x 642 | 643 | inx 644 | rts 645 | ;code 646 | 647 | code r> ; must be called using jsr 648 | pla 649 | sta W 650 | pla 651 | sta W+1 652 | inc W 653 | bne + 654 | inc W+1 655 | + 656 | dex 657 | pla 658 | sta LSB,x 659 | pla 660 | sta MSB,x 661 | jmp (W) 662 | ;code 663 | 664 | code r@ ; must be called using jsr 665 | txa 666 | tsx 667 | ldy $103,x 668 | sty W 669 | ldy $104,x 670 | tax 671 | dex 672 | sty MSB,x 673 | lda W 674 | sta LSB,x 675 | rts 676 | ;code 677 | 678 | code >r ; must be called using jsr 679 | pla 680 | sta W 681 | pla 682 | sta W+1 683 | inc W 684 | bne + 685 | inc W+1 686 | + 687 | lda MSB,x 688 | pha 689 | lda LSB,x 690 | pha 691 | inx 692 | jmp (W) 693 | ;code 694 | 695 | code or 696 | lda MSB,x 697 | ora MSB+1,x 698 | sta MSB+1,x 699 | lda LSB,x 700 | ora LSB+1,x 701 | sta LSB+1,x 702 | inx 703 | rts 704 | ;code 705 | 706 | code xor 707 | lda MSB,x 708 | eor MSB+1,x 709 | sta MSB+1,x 710 | lda LSB,x 711 | eor LSB+1,x 712 | sta LSB+1,x 713 | inx 714 | rts 715 | ;code 716 | 717 | code lshift 718 | - dec LSB,x 719 | bmi + 720 | asl LSB+1,x 721 | rol MSB+1,x 722 | jmp - 723 | + inx 724 | rts 725 | ;code 726 | 727 | code rshift 728 | - dec LSB,x 729 | bmi + 730 | lsr MSB+1,x 731 | ror LSB+1,x 732 | jmp - 733 | + inx 734 | rts 735 | ;code 736 | 737 | code < 738 | ldy #0 739 | sec 740 | lda LSB+1,x 741 | sbc LSB,x 742 | lda MSB+1,x 743 | sbc MSB,x 744 | bvc + 745 | eor #$80 746 | + bpl + 747 | dey 748 | + inx 749 | sty LSB,x 750 | sty MSB,x 751 | rts 752 | ;code 753 | 754 | code > 755 | jsr %swap% 756 | jmp %<% 757 | ;code 758 | 759 | code u< 760 | ldy #0 761 | lda MSB, x 762 | cmp MSB + 1, x 763 | bcc .false 764 | bne .true 765 | ; ok, msb are equal... 766 | lda LSB + 1, x 767 | cmp LSB, x 768 | bcs .false 769 | .true 770 | dey 771 | .false 772 | inx 773 | sty MSB, x 774 | sty LSB, x 775 | rts 776 | ;code 777 | 778 | code pick 779 | txa 780 | sta + + 1 781 | clc 782 | adc LSB,x 783 | tax 784 | inx 785 | lda LSB,x 786 | ldy MSB,x 787 | + ldx #0 788 | sta LSB,x 789 | sty MSB,x 790 | rts 791 | ;code 792 | 793 | code rot 794 | ldy MSB+2,x 795 | lda MSB+1,x 796 | sta MSB+2,x 797 | lda MSB,x 798 | sta MSB+1,x 799 | sty MSB,x 800 | ldy LSB+2,x 801 | lda LSB+1,x 802 | sta LSB+2,x 803 | lda LSB,x 804 | sta LSB+1,x 805 | sty LSB,x 806 | rts 807 | ;code 808 | 809 | code abs 810 | lda MSB,x 811 | bpl + 812 | jmp %negate% 813 | + rts 814 | ;code 815 | 816 | code m* 817 | jsr %2dup% 818 | jsr %xor% 819 | jsr %>r% 820 | jsr %>r% 821 | jsr %abs% 822 | jsr %r>% 823 | jsr %abs% 824 | jsr %um*% 825 | jsr %r>% 826 | jmp %?dnegate% 827 | ;code 828 | 829 | code um* ; wastes W, W2, y 830 | product = W 831 | lda #$00 832 | sta product+2 ; clear upper bits of product 833 | sta product+3 834 | ldy #$10 ; set binary count to 16 835 | .shift_r 836 | lsr MSB + 1, x ; multiplier+1 ; divide multiplier by 2 837 | ror LSB + 1, x ; multiplier 838 | bcc rotate_r 839 | lda product+2 ; get upper half of product and add multiplicand 840 | clc 841 | adc LSB, x ; multiplicand 842 | sta product+2 843 | lda product+3 844 | adc MSB, x ; multiplicand+1 845 | rotate_r 846 | ror ; rotate partial product 847 | sta product+3 848 | ror product+2 849 | ror product+1 850 | ror product 851 | dey 852 | bne .shift_r 853 | 854 | lda product 855 | sta LSB + 1, x 856 | lda product + 1 857 | sta MSB + 1, x 858 | lda product + 2 859 | sta LSB, x 860 | lda product + 3 861 | sta MSB, x 862 | rts 863 | ;code 864 | 865 | code * 866 | jsr %m*% 867 | inx 868 | rts 869 | ;code 870 | 871 | code um/mod 872 | N = W 873 | SEC 874 | LDA LSB+1,X ; Subtract hi cell of dividend by 875 | SBC LSB,X ; divisor to see if there's an overflow condition. 876 | LDA MSB+1,X 877 | SBC MSB,X 878 | BCS oflo ; Branch if /0 or overflow. 879 | 880 | LDA #17 ; Loop 17x. 881 | STA N ; Use N for loop counter. 882 | loop: ROL LSB+2,X ; Rotate dividend lo cell left one bit. 883 | ROL MSB+2,X 884 | DEC N ; Decrement loop counter. 885 | BEQ end ; If we're done, then branch to end. 886 | ROL LSB+1,X ; Otherwise rotate dividend hi cell left one bit. 887 | ROL MSB+1,X 888 | lda #0 889 | sta N+1 890 | ROL N+1 ; Rotate the bit carried out of above into N+1. 891 | 892 | SEC 893 | LDA LSB+1,X ; Subtract dividend hi cell minus divisor. 894 | SBC LSB,X 895 | STA N+2 ; Put result temporarily in N+2 (lo byte) 896 | LDA MSB+1,X 897 | SBC MSB,X 898 | TAY ; and Y (hi byte). 899 | LDA N+1 ; Remember now to bring in the bit carried out above. 900 | SBC #0 901 | BCC loop 902 | 903 | LDA N+2 ; If that didn't cause a borrow, 904 | STA LSB+1,X ; make the result from above to 905 | STY MSB+1,X ; be the new dividend hi cell 906 | bcs loop ; and then branch up. 907 | 908 | oflo: LDA #$FF ; If overflow or /0 condition found, 909 | STA LSB+1,X ; just put FFFF in both the remainder 910 | STA MSB+1,X 911 | STA LSB+2,X ; and the quotient. 912 | STA MSB+2,X 913 | 914 | end: INX 915 | jmp %swap% 916 | ;code 917 | 918 | code tuck 919 | jsr %swap% 920 | jmp %over% 921 | ;code 922 | 923 | code bye 924 | jmp BYE 925 | ;code 926 | 927 | code execute 928 | lda LSB, x 929 | sta W 930 | lda MSB, x 931 | sta W + 1 932 | inx 933 | jmp (W) 934 | ;code 935 | 936 | code (+loop) 937 | ; r> swap r> 2dup + 938 | jsr %r>% 939 | jsr %swap% 940 | jsr %r>% 941 | jsr %2dup% 942 | jsr %+% 943 | 944 | ; rot 0< if tuck swap else tuck then 945 | jsr %rot% 946 | inx 947 | lda MSB-1,x 948 | bpl .pl 949 | jsr %tuck% 950 | jsr %swap% 951 | jmp ++ 952 | .pl jsr %tuck% 953 | ++ 954 | ; r@ 1- -rot within 0= if 955 | jsr %r@% 956 | jsr %1-% 957 | jsr %rot% 958 | jsr %rot% 959 | jsr %within% 960 | 961 | inx 962 | lda MSB-1,x 963 | bne + 964 | 965 | ; >r >r [ ' branch jmp, ] then 966 | jsr %>r% 967 | jsr %>r% 968 | jmp %branch% 969 | + 970 | ; r> 2drop 2+ >r ; 971 | jsr %r>% 972 | inx 973 | inx 974 | jsr %2+% 975 | jsr %>r% 976 | rts 977 | ;code 978 | 979 | code dodoes 980 | ; behavior pointer address => W 981 | pla 982 | sta W 983 | pla 984 | sta W + 1 985 | 986 | inc W 987 | bne + 988 | inc W + 1 989 | + 990 | 991 | ; push data pointer to param stack 992 | dex 993 | lda W 994 | clc 995 | adc #2 996 | sta LSB,x 997 | lda W + 1 998 | adc #0 999 | sta MSB,x 1000 | 1001 | ldy #0 1002 | lda (W),y 1003 | sta W2 1004 | iny 1005 | lda (W),y 1006 | sta W2 + 1 1007 | jmp (W2) 1008 | ;code 1009 | 1010 | \ from cc65 memmove.s 1011 | \ 2003-08-20, Ullrich von Bassewitz 1012 | \ 2009-09-13, Christian Krueger -- performance increase (about 20%), 2013-07-25 improved unrolling 1013 | \ 2015-10-23, Greg King 1014 | code move 1015 | ; Check for the copy direction. If dest < src, we must copy upwards (start at 1016 | ; low addresses and increase pointers), otherwise we must copy downwards 1017 | ; (start at high addresses and decrease pointers). 1018 | ptr1 = W 1019 | ptr2 = W2 1020 | ptr3 = W3 1021 | txa 1022 | pha 1023 | 1024 | ldy #0 1025 | 1026 | ; ptr3 = n 1027 | lda MSB,x 1028 | sta ptr3+1 1029 | lda LSB,x 1030 | sta ptr3 1031 | 1032 | ; ptr1 = src 1033 | lda MSB+2,x 1034 | sta ptr1+1 1035 | lda LSB+2,x 1036 | sta ptr1 1037 | 1038 | ; ptr2 = dst 1039 | lda MSB+1,x 1040 | sta ptr2+1 1041 | lda LSB+1,x 1042 | sta ptr2 1043 | 1044 | ; Check for the copy direction. If dest < src, we must copy upwards (start at 1045 | ; low addresses and increase pointers), otherwise we must copy downwards 1046 | ; (start at high addresses and decrease pointers). 1047 | 1048 | cmp ptr1 1049 | lda ptr2+1 1050 | sbc ptr1+1 1051 | bcc memcpy_upwards ; Branch if dest < src (upwards copy) 1052 | 1053 | ; Copy downwards. Adjust the pointers to the end of the memory regions. 1054 | 1055 | lda ptr1+1 1056 | clc 1057 | adc ptr3+1 1058 | sta ptr1+1 1059 | 1060 | lda ptr2+1 1061 | clc 1062 | adc ptr3+1 1063 | sta ptr2+1 1064 | 1065 | ; handle fractions of a page size first 1066 | 1067 | ldy ptr3 ; count, low byte 1068 | bne .entry ; something to copy? 1069 | beq PageSizeCopy ; here like bra... 1070 | 1071 | .copyByte: 1072 | lda (ptr1),y 1073 | sta (ptr2),y 1074 | .entry: 1075 | dey 1076 | bne .copyByte 1077 | lda (ptr1),y ; copy remaining byte 1078 | sta (ptr2),y 1079 | 1080 | PageSizeCopy: ; assert Y = 0 1081 | ldx ptr3+1 ; number of pages 1082 | beq done ; none? -> done 1083 | 1084 | .initBase: 1085 | dec ptr1+1 ; adjust base... 1086 | dec ptr2+1 1087 | dey ; in entry case: 0 -> FF 1088 | .copyBytes: 1089 | lda (ptr1),y ; important: unrolling three times gives a nice 1090 | sta (ptr2),y ; 255/3 = 85 loop which ends at 0 1091 | dey 1092 | lda (ptr1),y ; important: unrolling three times gives a nice 1093 | sta (ptr2),y ; 255/3 = 85 loop which ends at 0 1094 | dey 1095 | lda (ptr1),y ; important: unrolling three times gives a nice 1096 | sta (ptr2),y ; 255/3 = 85 loop which ends at 0 1097 | dey 1098 | .copyEntry: ; in entry case: 0 -> FF 1099 | bne .copyBytes 1100 | lda (ptr1),y ; Y = 0, copy last byte 1101 | sta (ptr2),y 1102 | dex ; one page to copy less 1103 | bne .initBase ; still a page to copy? 1104 | 1105 | done 1106 | pla 1107 | tax 1108 | inx 1109 | inx 1110 | inx 1111 | rts 1112 | 1113 | memcpy_upwards: ; assert Y = 0 1114 | ldx ptr3+1 ; Get high byte of n 1115 | beq L2 ; Jump if zero 1116 | 1117 | L1: 1118 | lda (ptr1),Y ; copy a byte 1119 | sta (ptr2),Y 1120 | iny 1121 | lda (ptr1),Y ; copy a byte 1122 | sta (ptr2),Y 1123 | iny 1124 | bne L1 1125 | inc ptr1+1 1126 | inc ptr2+1 1127 | dex ; Next 256 byte block 1128 | bne L1 ; Repeat if any 1129 | 1130 | ; the following section could be 10% faster if we were able to copy 1131 | ; back to front - unfortunately we are forced to copy strict from 1132 | ; low to high since this function is also used for 1133 | ; memmove and blocks could be overlapping! 1134 | L2: ; assert Y = 0 1135 | ldx ptr3 ; Get the low byte of n 1136 | beq done ; something to copy 1137 | 1138 | L3: lda (ptr1),Y ; copy a byte 1139 | sta (ptr2),Y 1140 | iny 1141 | dex 1142 | bne L3 1143 | jmp done 1144 | ;code 1145 | 1146 | \ from cc65 memset.s 1147 | \ Ullrich von Bassewitz, 29.05.1998 1148 | \ Performance increase (about 20%) by 1149 | \ Christian Krueger, 12.09.2009, slightly improved 12.01.2011 1150 | code fill 1151 | ptr1 = W 1152 | ptr2 = W2 1153 | ptr3 = W3 1154 | 1155 | txa 1156 | pha 1157 | 1158 | lda MSB+1,x 1159 | sta ptr3+1 1160 | lda LSB+1,x 1161 | sta ptr3 ; Save n 1162 | 1163 | ; ptr1 = c-addr 1164 | lda MSB+2,x 1165 | sta ptr1+1 1166 | lda LSB+2,x 1167 | sta ptr1 1168 | 1169 | ; x = char 1170 | lda LSB,x 1171 | tax 1172 | ldy #0 1173 | 1174 | lsr ptr3+1 ; divide number of 1175 | ror ptr3 ; bytes by two to increase 1176 | bcc evenCount ; speed (ptr3 = ptr3/2) 1177 | oddCount: 1178 | ; y is still 0 here 1179 | txa ; restore fill value 1180 | sta (ptr1),y ; save value and increase 1181 | inc ptr1 ; dest. pointer 1182 | bne evenCount 1183 | inc ptr1+1 1184 | evenCount: 1185 | lda ptr1 ; build second pointer section 1186 | clc 1187 | adc ptr3 ; ptr2 = ptr1 + (length/2) <- ptr3 1188 | sta ptr2 1189 | lda ptr1+1 1190 | adc ptr3+1 1191 | sta ptr2+1 1192 | 1193 | txa ; restore fill value 1194 | ldx ptr3+1 ; Get high byte of n 1195 | beq .L2 ; Jump if zero 1196 | 1197 | ; Set 256/512 byte blocks 1198 | ; y is still 0 here 1199 | .L1: 1200 | sta (ptr1),y ; Set byte in lower section 1201 | sta (ptr2),y ; Set byte in upper section 1202 | iny 1203 | sta (ptr1),y ; Set byte in lower section 1204 | sta (ptr2),y ; Set byte in upper section 1205 | iny 1206 | 1207 | bne .L1 1208 | inc ptr1+1 1209 | inc ptr2+1 1210 | dex ; Next 256 byte block 1211 | bne .L1 ; Repeat if any 1212 | 1213 | ; Set the remaining bytes if any 1214 | 1215 | .L2: ldy ptr3 ; Get the low byte of n 1216 | beq leave ; something to set? No -> leave 1217 | 1218 | .L3: dey 1219 | sta (ptr1),y ; set bytes in low 1220 | sta (ptr2),y ; and high section 1221 | bne .L3 ; flags still up to date from dey! 1222 | leave: 1223 | pla 1224 | tax 1225 | inx 1226 | inx 1227 | inx 1228 | rts 1229 | ;code 1230 | 1231 | code key? 1232 | lda $c6 ; number of characters in keyboard buffer 1233 | beq + 1234 | lda #$ff 1235 | + tay 1236 | jmp %pushya% 1237 | ;code 1238 | 1239 | code key 1240 | - lda $c6 1241 | beq - 1242 | stx W 1243 | jsr $e5b4 1244 | ldx W 1245 | ldy #0 1246 | jmp %pushya% 1247 | ;code 1248 | 1249 | variable curr 1250 | : (accept) 1251 | $cc >r 0 $cc c! \ enable cursor 1252 | swap dup >r curr ! 1253 | begin 1254 | key 1255 | dup $d = if \ cr 1256 | 2drop curr @ r> - 1257 | space r> $cc c! \ reset cursor 1258 | exit 1259 | else dup $14 = if \ del 1260 | curr @ r@ > if 1261 | emit -1 curr +! 1+ 1262 | else drop then 1263 | else dup $7f and $20 < if 1264 | drop \ ignore 1265 | else 1266 | \ process character 1267 | over if dup curr @ c! 1268 | emit 1- 1 curr +! 1269 | else drop then 1270 | then then then 1271 | again ; 1272 | 1273 | \ Using this trampoline to avoid overriding the Python accept. 1274 | code accept ; ( addr u -- u ) 1275 | jmp %(accept)% 1276 | ;code 1277 | 1278 | code >body 1279 | jsr %litc% 1280 | !byte 5 ; skips jsr dodoes and code pointer 1281 | jmp %+% 1282 | ;code 1283 | 1284 | code (?do) 1285 | lda LSB,x 1286 | cmp LSB+1,x 1287 | bne .enter_loop 1288 | lda MSB,x 1289 | cmp MSB+1,x 1290 | bne .enter_loop 1291 | 1292 | ; skip loop 1293 | inx 1294 | inx 1295 | jmp %branch% 1296 | 1297 | .enter_loop 1298 | pla 1299 | tay 1300 | pla 1301 | sta W 1302 | 1303 | lda MSB+1,x 1304 | pha 1305 | lda LSB+1,x 1306 | pha 1307 | 1308 | lda MSB,x 1309 | pha 1310 | lda LSB,x 1311 | pha 1312 | 1313 | inx 1314 | inx 1315 | 1316 | ; ip += 2 1317 | iny 1318 | bne + 1319 | inc W 1320 | + iny 1321 | bne + 1322 | inc W 1323 | + 1324 | lda W 1325 | pha 1326 | tya 1327 | pha 1328 | rts 1329 | ;code 1330 | 1331 | code (of) 1332 | lda LSB,x 1333 | cmp LSB+1,x 1334 | bne .endof 1335 | lda MSB,x 1336 | cmp MSB+1,x 1337 | bne .endof 1338 | ; enter 1339 | inx 1340 | inx 1341 | jsr %r>% 1342 | jsr %2+% 1343 | jsr %>r% 1344 | rts 1345 | .endof inx 1346 | jmp %branch% 1347 | ;code 1348 | 1349 | \ This is obviously not a proper QUIT, but since we do not have QUIT on C64, this is at least something. 1350 | code quit 1351 | jmp %bye% 1352 | ;code 1353 | 1354 | code page 1355 | lda #$93 1356 | jmp PUTCHR 1357 | ;code 1358 | 1359 | : environment? 1360 | 2dup s" /COUNTED-STRING" s= if 2drop 255 true exit then 1361 | 2dup s" /HOLD" s= if 2drop 34 true exit then \ minimum size: (2 x n) + 2 characters, where n is number of bits in a cell 1362 | 2dup s" /PAD" s= if 2drop 84 true exit then \ minimum size 1363 | 2dup s" ADDRESS-UNIT-BITS" s= if 2drop 8 true exit then \ 8 bits in a byte 1364 | 2dup s" FLOORED" s= if 2drop true true exit then \ symmetric division considered harmful 1365 | 2dup s" MAX-CHAR" s= if 2drop 255 true exit then 1366 | 2dup s" MAX-D" s= if 2drop -1 $7fff true exit then 1367 | 2dup s" MAX-N" s= if 2drop $7fff true exit then 1368 | 2dup s" MAX-U" s= if 2drop -1 true exit then 1369 | 2dup s" MAX-UD" s= if 2drop -1 -1 true exit then 1370 | 2dup s" RETURN-STACK-CELLS" s= if 2drop $7a true exit then \ When entering start word, SP=$f4 1371 | 2dup s" STACK-CELLS" s= if 2drop $38 true exit then 1372 | 2drop false ; 1373 | -------------------------------------------------------------------------------- /test/testcore.fs: -------------------------------------------------------------------------------- 1 | \ From: John Hayes S1I 2 | \ Subject: core.fr 3 | \ Date: Mon, 27 Nov 95 13:10 4 | 5 | \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY 6 | \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 7 | \ VERSION 1.2 8 | \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM. 9 | \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE 10 | \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND 11 | \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1. 12 | \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"... 13 | \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?... 14 | 15 | CR 16 | TESTING CORE WORDS 17 | HEX 18 | 19 | \ ------------------------------------------------------------------------ 20 | TESTING BASIC ASSUMPTIONS 21 | 22 | T{ -> }T \ START WITH CLEAN SLATE 23 | ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) 24 | T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T 25 | T{ 0 BITSSET? -> 0 }T ( ZERO IS ALL BITS CLEAR ) 26 | T{ 1 BITSSET? -> 0 0 }T ( OTHER NUMBER HAVE AT LEAST ONE BIT ) 27 | T{ -1 BITSSET? -> 0 0 }T 28 | 29 | \ ------------------------------------------------------------------------ 30 | TESTING BOOLEANS: INVERT AND OR XOR 31 | 32 | T{ 0 0 AND -> 0 }T 33 | T{ 0 1 AND -> 0 }T 34 | T{ 1 0 AND -> 0 }T 35 | T{ 1 1 AND -> 1 }T 36 | 37 | T{ 0 INVERT 1 AND -> 1 }T 38 | T{ 1 INVERT 1 AND -> 0 }T 39 | 40 | 0 CONSTANT 0S 41 | 0 INVERT CONSTANT 1S 42 | 43 | T{ 0S INVERT -> 1S }T 44 | T{ 1S INVERT -> 0S }T 45 | 46 | T{ 0S 0S AND -> 0S }T 47 | T{ 0S 1S AND -> 0S }T 48 | T{ 1S 0S AND -> 0S }T 49 | T{ 1S 1S AND -> 1S }T 50 | 51 | T{ 0S 0S OR -> 0S }T 52 | T{ 0S 1S OR -> 1S }T 53 | T{ 1S 0S OR -> 1S }T 54 | T{ 1S 1S OR -> 1S }T 55 | 56 | T{ 0S 0S XOR -> 0S }T 57 | T{ 0S 1S XOR -> 1S }T 58 | T{ 1S 0S XOR -> 1S }T 59 | T{ 1S 1S XOR -> 0S }T 60 | 61 | \ ------------------------------------------------------------------------ 62 | TESTING 2* 2/ LSHIFT RSHIFT 63 | 64 | ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) 65 | 1S 1 RSHIFT INVERT CONSTANT MSB 66 | T{ MSB BITSSET? -> 0 0 }T 67 | 68 | T{ 0S 2* -> 0S }T 69 | T{ 1 2* -> 2 }T 70 | T{ 4000 2* -> 8000 }T 71 | T{ 1S 2* 1 XOR -> 1S }T 72 | T{ MSB 2* -> 0S }T 73 | 74 | T{ 0S 2/ -> 0S }T 75 | T{ 1 2/ -> 0 }T 76 | T{ 4000 2/ -> 2000 }T 77 | T{ 1S 2/ -> 1S }T \ MSB PROPOGATED 78 | T{ 1S 1 XOR 2/ -> 1S }T 79 | T{ MSB 2/ MSB AND -> MSB }T 80 | 81 | T{ 1 0 LSHIFT -> 1 }T 82 | T{ 1 1 LSHIFT -> 2 }T 83 | T{ 1 2 LSHIFT -> 4 }T 84 | T{ 1 F LSHIFT -> 8000 }T \ BIGGEST GUARANTEED SHIFT 85 | T{ 1S 1 LSHIFT 1 XOR -> 1S }T 86 | T{ MSB 1 LSHIFT -> 0 }T 87 | 88 | T{ 1 0 RSHIFT -> 1 }T 89 | T{ 1 1 RSHIFT -> 0 }T 90 | T{ 2 1 RSHIFT -> 1 }T 91 | T{ 4 2 RSHIFT -> 1 }T 92 | T{ 8000 F RSHIFT -> 1 }T \ BIGGEST 93 | T{ MSB 1 RSHIFT MSB AND -> 0 }T \ RSHIFT ZERO FILLS MSBS 94 | T{ MSB 1 RSHIFT 2* -> MSB }T 95 | 96 | \ ------------------------------------------------------------------------ 97 | TESTING COMPARISONS: 0= = 0< < > U< MIN MAX 98 | 0 INVERT CONSTANT MAX-UINT 99 | 0 INVERT 1 RSHIFT CONSTANT MAX-INT 100 | 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT 101 | 0 INVERT 1 RSHIFT CONSTANT MID-UINT 102 | 0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 103 | 104 | 0S CONSTANT 105 | 1S CONSTANT 106 | 107 | T{ 0 0= -> }T 108 | T{ 1 0= -> }T 109 | T{ 2 0= -> }T 110 | T{ -1 0= -> }T 111 | T{ MAX-UINT 0= -> }T 112 | T{ MIN-INT 0= -> }T 113 | T{ MAX-INT 0= -> }T 114 | 115 | T{ 0 0 = -> }T 116 | T{ 1 1 = -> }T 117 | T{ -1 -1 = -> }T 118 | T{ 1 0 = -> }T 119 | T{ -1 0 = -> }T 120 | T{ 0 1 = -> }T 121 | T{ 0 -1 = -> }T 122 | 123 | T{ 0 0< -> }T 124 | T{ -1 0< -> }T 125 | T{ MIN-INT 0< -> }T 126 | T{ 1 0< -> }T 127 | T{ MAX-INT 0< -> }T 128 | 129 | T{ 0 1 < -> }T 130 | T{ 1 2 < -> }T 131 | T{ -1 0 < -> }T 132 | T{ -1 1 < -> }T 133 | T{ MIN-INT 0 < -> }T 134 | T{ MIN-INT MAX-INT < -> }T 135 | T{ 0 MAX-INT < -> }T 136 | T{ 0 0 < -> }T 137 | T{ 1 1 < -> }T 138 | T{ 1 0 < -> }T 139 | T{ 2 1 < -> }T 140 | T{ 0 -1 < -> }T 141 | T{ 1 -1 < -> }T 142 | T{ 0 MIN-INT < -> }T 143 | T{ MAX-INT MIN-INT < -> }T 144 | T{ MAX-INT 0 < -> }T 145 | 146 | T{ 0 1 > -> }T 147 | T{ 1 2 > -> }T 148 | T{ -1 0 > -> }T 149 | T{ -1 1 > -> }T 150 | T{ MIN-INT 0 > -> }T 151 | T{ MIN-INT MAX-INT > -> }T 152 | T{ 0 MAX-INT > -> }T 153 | T{ 0 0 > -> }T 154 | T{ 1 1 > -> }T 155 | T{ 1 0 > -> }T 156 | T{ 2 1 > -> }T 157 | T{ 0 -1 > -> }T 158 | T{ 1 -1 > -> }T 159 | T{ 0 MIN-INT > -> }T 160 | T{ MAX-INT MIN-INT > -> }T 161 | T{ MAX-INT 0 > -> }T 162 | 163 | T{ 0 1 U< -> }T 164 | T{ 1 2 U< -> }T 165 | T{ 0 MID-UINT U< -> }T 166 | T{ 0 MAX-UINT U< -> }T 167 | T{ MID-UINT MAX-UINT U< -> }T 168 | T{ 0 0 U< -> }T 169 | T{ 1 1 U< -> }T 170 | T{ 1 0 U< -> }T 171 | T{ 2 1 U< -> }T 172 | T{ MID-UINT 0 U< -> }T 173 | T{ MAX-UINT 0 U< -> }T 174 | T{ MAX-UINT MID-UINT U< -> }T 175 | 176 | T{ 0 1 MIN -> 0 }T 177 | T{ 1 2 MIN -> 1 }T 178 | T{ -1 0 MIN -> -1 }T 179 | T{ -1 1 MIN -> -1 }T 180 | T{ MIN-INT 0 MIN -> MIN-INT }T 181 | T{ MIN-INT MAX-INT MIN -> MIN-INT }T 182 | T{ 0 MAX-INT MIN -> 0 }T 183 | T{ 0 0 MIN -> 0 }T 184 | T{ 1 1 MIN -> 1 }T 185 | T{ 1 0 MIN -> 0 }T 186 | T{ 2 1 MIN -> 1 }T 187 | T{ 0 -1 MIN -> -1 }T 188 | T{ 1 -1 MIN -> -1 }T 189 | T{ 0 MIN-INT MIN -> MIN-INT }T 190 | T{ MAX-INT MIN-INT MIN -> MIN-INT }T 191 | T{ MAX-INT 0 MIN -> 0 }T 192 | 193 | T{ 0 1 MAX -> 1 }T 194 | T{ 1 2 MAX -> 2 }T 195 | T{ -1 0 MAX -> 0 }T 196 | T{ -1 1 MAX -> 1 }T 197 | T{ MIN-INT 0 MAX -> 0 }T 198 | T{ MIN-INT MAX-INT MAX -> MAX-INT }T 199 | T{ 0 MAX-INT MAX -> MAX-INT }T 200 | T{ 0 0 MAX -> 0 }T 201 | T{ 1 1 MAX -> 1 }T 202 | T{ 1 0 MAX -> 1 }T 203 | T{ 2 1 MAX -> 2 }T 204 | T{ 0 -1 MAX -> 0 }T 205 | T{ 1 -1 MAX -> 1 }T 206 | T{ 0 MIN-INT MAX -> 0 }T 207 | T{ MAX-INT MIN-INT MAX -> MAX-INT }T 208 | T{ MAX-INT 0 MAX -> MAX-INT }T 209 | 210 | \ ------------------------------------------------------------------------ 211 | TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP 212 | 213 | T{ 1 2 2DROP -> }T 214 | T{ 1 2 2DUP -> 1 2 1 2 }T 215 | T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T 216 | T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T 217 | T{ 0 ?DUP -> 0 }T 218 | T{ 1 ?DUP -> 1 1 }T 219 | T{ -1 ?DUP -> -1 -1 }T 220 | T{ DEPTH -> 0 }T 221 | T{ 0 DEPTH -> 0 1 }T 222 | T{ 0 1 DEPTH -> 0 1 2 }T 223 | T{ 0 DROP -> }T 224 | T{ 1 2 DROP -> 1 }T 225 | T{ 1 DUP -> 1 1 }T 226 | T{ 1 2 OVER -> 1 2 1 }T 227 | T{ 1 2 3 ROT -> 2 3 1 }T 228 | T{ 1 2 SWAP -> 2 1 }T 229 | 230 | \ ------------------------------------------------------------------------ 231 | TESTING >R R> R@ 232 | 233 | T{ : GR1 >R R> ; -> }T 234 | T{ : GR2 >R R@ R> DROP ; -> }T 235 | T{ 123 GR1 -> 123 }T 236 | T{ 123 GR2 -> 123 }T 237 | T{ 1S GR1 -> 1S }T ( RETURN STACK HOLDS CELLS ) 238 | 239 | \ ------------------------------------------------------------------------ 240 | TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE 241 | 242 | T{ 0 5 + -> 5 }T 243 | T{ 5 0 + -> 5 }T 244 | T{ 0 -5 + -> -5 }T 245 | T{ -5 0 + -> -5 }T 246 | T{ 1 2 + -> 3 }T 247 | T{ 1 -2 + -> -1 }T 248 | T{ -1 2 + -> 1 }T 249 | T{ -1 -2 + -> -3 }T 250 | T{ -1 1 + -> 0 }T 251 | T{ MID-UINT 1 + -> MID-UINT+1 }T 252 | 253 | T{ 0 5 - -> -5 }T 254 | T{ 5 0 - -> 5 }T 255 | T{ 0 -5 - -> 5 }T 256 | T{ -5 0 - -> -5 }T 257 | T{ 1 2 - -> -1 }T 258 | T{ 1 -2 - -> 3 }T 259 | T{ -1 2 - -> -3 }T 260 | T{ -1 -2 - -> 1 }T 261 | T{ 0 1 - -> -1 }T 262 | T{ MID-UINT+1 1 - -> MID-UINT }T 263 | 264 | T{ 0 1+ -> 1 }T 265 | T{ -1 1+ -> 0 }T 266 | T{ 1 1+ -> 2 }T 267 | T{ MID-UINT 1+ -> MID-UINT+1 }T 268 | 269 | T{ 2 1- -> 1 }T 270 | T{ 1 1- -> 0 }T 271 | T{ 0 1- -> -1 }T 272 | T{ MID-UINT+1 1- -> MID-UINT }T 273 | 274 | T{ 0 NEGATE -> 0 }T 275 | T{ 1 NEGATE -> -1 }T 276 | T{ -1 NEGATE -> 1 }T 277 | T{ 2 NEGATE -> -2 }T 278 | T{ -2 NEGATE -> 2 }T 279 | 280 | T{ 0 ABS -> 0 }T 281 | T{ 1 ABS -> 1 }T 282 | T{ -1 ABS -> 1 }T 283 | T{ MIN-INT ABS -> MID-UINT+1 }T 284 | 285 | \ ------------------------------------------------------------------------ 286 | TESTING MULTIPLY: S>D * M* UM* 287 | 288 | T{ 0 S>D -> 0 0 }T 289 | T{ 1 S>D -> 1 0 }T 290 | T{ 2 S>D -> 2 0 }T 291 | T{ -1 S>D -> -1 -1 }T 292 | T{ -2 S>D -> -2 -1 }T 293 | T{ MIN-INT S>D -> MIN-INT -1 }T 294 | T{ MAX-INT S>D -> MAX-INT 0 }T 295 | 296 | T{ 0 0 M* -> 0 S>D }T 297 | T{ 0 1 M* -> 0 S>D }T 298 | T{ 1 0 M* -> 0 S>D }T 299 | T{ 1 2 M* -> 2 S>D }T 300 | T{ 2 1 M* -> 2 S>D }T 301 | T{ 3 3 M* -> 9 S>D }T 302 | T{ -3 3 M* -> -9 S>D }T 303 | T{ 3 -3 M* -> -9 S>D }T 304 | T{ -3 -3 M* -> 9 S>D }T 305 | T{ 0 MIN-INT M* -> 0 S>D }T 306 | T{ 1 MIN-INT M* -> MIN-INT S>D }T 307 | T{ 2 MIN-INT M* -> 0 1S }T 308 | T{ 0 MAX-INT M* -> 0 S>D }T 309 | T{ 1 MAX-INT M* -> MAX-INT S>D }T 310 | T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T 311 | T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T 312 | T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T 313 | T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T 314 | 315 | T{ 0 0 * -> 0 }T \ TEST IDENTITIES 316 | T{ 0 1 * -> 0 }T 317 | T{ 1 0 * -> 0 }T 318 | T{ 1 2 * -> 2 }T 319 | T{ 2 1 * -> 2 }T 320 | T{ 3 3 * -> 9 }T 321 | T{ -3 3 * -> -9 }T 322 | T{ 3 -3 * -> -9 }T 323 | T{ -3 -3 * -> 9 }T 324 | 325 | T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T 326 | T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T 327 | T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T 328 | 329 | T{ 0 0 UM* -> 0 0 }T 330 | T{ 0 1 UM* -> 0 0 }T 331 | T{ 1 0 UM* -> 0 0 }T 332 | T{ 1 2 UM* -> 2 0 }T 333 | T{ 2 1 UM* -> 2 0 }T 334 | T{ 3 3 UM* -> 9 0 }T 335 | 336 | T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T 337 | T{ MID-UINT+1 2 UM* -> 0 1 }T 338 | T{ MID-UINT+1 4 UM* -> 0 2 }T 339 | T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T 340 | T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T 341 | 342 | \ ------------------------------------------------------------------------ 343 | TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD 344 | 345 | T{ 0 S>D 1 FM/MOD -> 0 0 }T 346 | T{ 1 S>D 1 FM/MOD -> 0 1 }T 347 | T{ 2 S>D 1 FM/MOD -> 0 2 }T 348 | T{ -1 S>D 1 FM/MOD -> 0 -1 }T 349 | T{ -2 S>D 1 FM/MOD -> 0 -2 }T 350 | T{ 0 S>D -1 FM/MOD -> 0 0 }T 351 | T{ 1 S>D -1 FM/MOD -> 0 -1 }T 352 | T{ 2 S>D -1 FM/MOD -> 0 -2 }T 353 | T{ -1 S>D -1 FM/MOD -> 0 1 }T 354 | T{ -2 S>D -1 FM/MOD -> 0 2 }T 355 | T{ 2 S>D 2 FM/MOD -> 0 1 }T 356 | T{ -1 S>D -1 FM/MOD -> 0 1 }T 357 | T{ -2 S>D -2 FM/MOD -> 0 1 }T 358 | T{ 7 S>D 3 FM/MOD -> 1 2 }T 359 | T{ 7 S>D -3 FM/MOD -> -2 -3 }T 360 | T{ -7 S>D 3 FM/MOD -> 2 -3 }T 361 | T{ -7 S>D -3 FM/MOD -> -1 2 }T 362 | T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T 363 | T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T 364 | T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T 365 | T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T 366 | T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T 367 | T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T 368 | T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T 369 | T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T 370 | T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T 371 | T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T 372 | T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T 373 | T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T 374 | T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T 375 | T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T 376 | T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T 377 | T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T 378 | T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T 379 | 380 | T{ 0 S>D 1 SM/REM -> 0 0 }T 381 | T{ 1 S>D 1 SM/REM -> 0 1 }T 382 | T{ 2 S>D 1 SM/REM -> 0 2 }T 383 | T{ -1 S>D 1 SM/REM -> 0 -1 }T 384 | T{ -2 S>D 1 SM/REM -> 0 -2 }T 385 | T{ 0 S>D -1 SM/REM -> 0 0 }T 386 | T{ 1 S>D -1 SM/REM -> 0 -1 }T 387 | T{ 2 S>D -1 SM/REM -> 0 -2 }T 388 | T{ -1 S>D -1 SM/REM -> 0 1 }T 389 | T{ -2 S>D -1 SM/REM -> 0 2 }T 390 | T{ 2 S>D 2 SM/REM -> 0 1 }T 391 | T{ -1 S>D -1 SM/REM -> 0 1 }T 392 | T{ -2 S>D -2 SM/REM -> 0 1 }T 393 | T{ 7 S>D 3 SM/REM -> 1 2 }T 394 | T{ 7 S>D -3 SM/REM -> 1 -2 }T 395 | T{ -7 S>D 3 SM/REM -> -1 -2 }T 396 | T{ -7 S>D -3 SM/REM -> -1 2 }T 397 | T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T 398 | T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T 399 | T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T 400 | T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T 401 | T{ 1S 1 4 SM/REM -> 3 MAX-INT }T 402 | T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T 403 | T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T 404 | T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T 405 | T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T 406 | T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T 407 | T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T 408 | T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T 409 | T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T 410 | 411 | T{ 0 0 1 UM/MOD -> 0 0 }T 412 | T{ 1 0 1 UM/MOD -> 0 1 }T 413 | T{ 1 0 2 UM/MOD -> 1 0 }T 414 | T{ 3 0 2 UM/MOD -> 1 1 }T 415 | T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T 416 | T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T 417 | T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T 418 | 419 | : IFFLOORED 420 | [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ; 421 | 422 | : IFSYM 423 | [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ; 424 | 425 | \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION. 426 | \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST. 427 | 428 | IFFLOORED : T/MOD >R S>D R> FM/MOD ; 429 | IFFLOORED : T/ T/MOD SWAP DROP ; 430 | IFFLOORED : TMOD T/MOD DROP ; 431 | IFFLOORED : T*/MOD >R M* R> FM/MOD ; 432 | IFFLOORED : T*/ T*/MOD SWAP DROP ; 433 | IFSYM : T/MOD >R S>D R> SM/REM ; 434 | IFSYM : T/ T/MOD SWAP DROP ; 435 | IFSYM : TMOD T/MOD DROP ; 436 | IFSYM : T*/MOD >R M* R> SM/REM ; 437 | IFSYM : T*/ T*/MOD SWAP DROP ; 438 | 439 | T{ 0 1 /MOD -> 0 1 T/MOD }T 440 | T{ 1 1 /MOD -> 1 1 T/MOD }T 441 | T{ 2 1 /MOD -> 2 1 T/MOD }T 442 | T{ -1 1 /MOD -> -1 1 T/MOD }T 443 | T{ -2 1 /MOD -> -2 1 T/MOD }T 444 | T{ 0 -1 /MOD -> 0 -1 T/MOD }T 445 | T{ 1 -1 /MOD -> 1 -1 T/MOD }T 446 | T{ 2 -1 /MOD -> 2 -1 T/MOD }T 447 | T{ -1 -1 /MOD -> -1 -1 T/MOD }T 448 | T{ -2 -1 /MOD -> -2 -1 T/MOD }T 449 | T{ 2 2 /MOD -> 2 2 T/MOD }T 450 | T{ -1 -1 /MOD -> -1 -1 T/MOD }T 451 | T{ -2 -2 /MOD -> -2 -2 T/MOD }T 452 | T{ 7 3 /MOD -> 7 3 T/MOD }T 453 | T{ 7 -3 /MOD -> 7 -3 T/MOD }T 454 | T{ -7 3 /MOD -> -7 3 T/MOD }T 455 | T{ -7 -3 /MOD -> -7 -3 T/MOD }T 456 | T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T 457 | T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T 458 | T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T 459 | T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T 460 | 461 | T{ 0 1 / -> 0 1 T/ }T 462 | T{ 1 1 / -> 1 1 T/ }T 463 | T{ 2 1 / -> 2 1 T/ }T 464 | T{ -1 1 / -> -1 1 T/ }T 465 | T{ -2 1 / -> -2 1 T/ }T 466 | T{ 0 -1 / -> 0 -1 T/ }T 467 | T{ 1 -1 / -> 1 -1 T/ }T 468 | T{ 2 -1 / -> 2 -1 T/ }T 469 | T{ -1 -1 / -> -1 -1 T/ }T 470 | T{ -2 -1 / -> -2 -1 T/ }T 471 | T{ 2 2 / -> 2 2 T/ }T 472 | T{ -1 -1 / -> -1 -1 T/ }T 473 | T{ -2 -2 / -> -2 -2 T/ }T 474 | T{ 7 3 / -> 7 3 T/ }T 475 | T{ 7 -3 / -> 7 -3 T/ }T 476 | T{ -7 3 / -> -7 3 T/ }T 477 | T{ -7 -3 / -> -7 -3 T/ }T 478 | T{ MAX-INT 1 / -> MAX-INT 1 T/ }T 479 | T{ MIN-INT 1 / -> MIN-INT 1 T/ }T 480 | T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T 481 | T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T 482 | 483 | T{ 0 1 MOD -> 0 1 TMOD }T 484 | T{ 1 1 MOD -> 1 1 TMOD }T 485 | T{ 2 1 MOD -> 2 1 TMOD }T 486 | T{ -1 1 MOD -> -1 1 TMOD }T 487 | T{ -2 1 MOD -> -2 1 TMOD }T 488 | T{ 0 -1 MOD -> 0 -1 TMOD }T 489 | T{ 1 -1 MOD -> 1 -1 TMOD }T 490 | T{ 2 -1 MOD -> 2 -1 TMOD }T 491 | T{ -1 -1 MOD -> -1 -1 TMOD }T 492 | T{ -2 -1 MOD -> -2 -1 TMOD }T 493 | T{ 2 2 MOD -> 2 2 TMOD }T 494 | T{ -1 -1 MOD -> -1 -1 TMOD }T 495 | T{ -2 -2 MOD -> -2 -2 TMOD }T 496 | T{ 7 3 MOD -> 7 3 TMOD }T 497 | T{ 7 -3 MOD -> 7 -3 TMOD }T 498 | T{ -7 3 MOD -> -7 3 TMOD }T 499 | T{ -7 -3 MOD -> -7 -3 TMOD }T 500 | T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T 501 | T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T 502 | T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T 503 | T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T 504 | 505 | T{ 0 2 1 */ -> 0 2 1 T*/ }T 506 | T{ 1 2 1 */ -> 1 2 1 T*/ }T 507 | T{ 2 2 1 */ -> 2 2 1 T*/ }T 508 | T{ -1 2 1 */ -> -1 2 1 T*/ }T 509 | T{ -2 2 1 */ -> -2 2 1 T*/ }T 510 | T{ 0 2 -1 */ -> 0 2 -1 T*/ }T 511 | T{ 1 2 -1 */ -> 1 2 -1 T*/ }T 512 | T{ 2 2 -1 */ -> 2 2 -1 T*/ }T 513 | T{ -1 2 -1 */ -> -1 2 -1 T*/ }T 514 | T{ -2 2 -1 */ -> -2 2 -1 T*/ }T 515 | T{ 2 2 2 */ -> 2 2 2 T*/ }T 516 | T{ -1 2 -1 */ -> -1 2 -1 T*/ }T 517 | T{ -2 2 -2 */ -> -2 2 -2 T*/ }T 518 | T{ 7 2 3 */ -> 7 2 3 T*/ }T 519 | T{ 7 2 -3 */ -> 7 2 -3 T*/ }T 520 | T{ -7 2 3 */ -> -7 2 3 T*/ }T 521 | T{ -7 2 -3 */ -> -7 2 -3 T*/ }T 522 | T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T 523 | T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T 524 | 525 | T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T 526 | T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T 527 | T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T 528 | T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T 529 | T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T 530 | T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T 531 | T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T 532 | T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T 533 | T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T 534 | T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T 535 | T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T 536 | T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T 537 | T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T 538 | T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T 539 | T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T 540 | T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T 541 | T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T 542 | T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T 543 | T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T 544 | 545 | \ ------------------------------------------------------------------------ 546 | TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT 547 | 548 | HERE 1 ALLOT 549 | HERE 550 | CONSTANT 2NDA 551 | CONSTANT 1STA 552 | T{ 1STA 2NDA U< -> }T \ HERE MUST GROW WITH ALLOT 553 | T{ 1STA 1+ -> 2NDA }T \ ... BY ONE ADDRESS UNIT 554 | ( MISSING TEST: NEGATIVE ALLOT ) 555 | 556 | \ Added by GWJ so that ALIGN can be used before , (comma) is tested 557 | 1 ALIGNED CONSTANT ALMNT \ -- 1|2|4|8 for 8|16|32|64 bit alignment 558 | ALIGN 559 | T{ HERE 1 ALLOT ALIGN HERE SWAP - ALMNT = -> }T 560 | \ End of extra test 561 | 562 | HERE 1 , 563 | HERE 2 , 564 | CONSTANT 2ND 565 | CONSTANT 1ST 566 | T{ 1ST 2ND U< -> }T \ HERE MUST GROW WITH ALLOT 567 | T{ 1ST CELL+ -> 2ND }T \ ... BY ONE CELL 568 | T{ 1ST 1 CELLS + -> 2ND }T 569 | T{ 1ST @ 2ND @ -> 1 2 }T 570 | T{ 5 1ST ! -> }T 571 | T{ 1ST @ 2ND @ -> 5 2 }T 572 | T{ 6 2ND ! -> }T 573 | T{ 1ST @ 2ND @ -> 5 6 }T 574 | T{ 1ST 2@ -> 6 5 }T 575 | T{ 2 1 1ST 2! -> }T 576 | T{ 1ST 2@ -> 2 1 }T 577 | T{ 1S 1ST ! 1ST @ -> 1S }T \ CAN STORE CELL-WIDE VALUE 578 | 579 | HERE 1 C, 580 | HERE 2 C, 581 | CONSTANT 2NDC 582 | CONSTANT 1STC 583 | T{ 1STC 2NDC U< -> }T \ HERE MUST GROW WITH ALLOT 584 | T{ 1STC CHAR+ -> 2NDC }T \ ... BY ONE CHAR 585 | T{ 1STC 1 CHARS + -> 2NDC }T 586 | T{ 1STC C@ 2NDC C@ -> 1 2 }T 587 | T{ 3 1STC C! -> }T 588 | T{ 1STC C@ 2NDC C@ -> 3 2 }T 589 | T{ 4 2NDC C! -> }T 590 | T{ 1STC C@ 2NDC C@ -> 3 4 }T 591 | 592 | ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT 593 | CONSTANT A-ADDR CONSTANT UA-ADDR 594 | T{ UA-ADDR ALIGNED -> A-ADDR }T 595 | T{ 1 A-ADDR C! A-ADDR C@ -> 1 }T 596 | T{ 1234 A-ADDR ! A-ADDR @ -> 1234 }T 597 | T{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 }T 598 | T{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 }T 599 | T{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 }T 600 | T{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 }T 601 | T{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 }T 602 | 603 | : BITS ( X -- U ) 604 | 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ; 605 | ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS ) 606 | T{ 1 CHARS 1 < -> }T 607 | T{ 1 CHARS 1 CELLS > -> }T 608 | ( TBD: HOW TO FIND NUMBER OF BITS? ) 609 | 610 | ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) 611 | T{ 1 CELLS 1 < -> }T 612 | T{ 1 CELLS 1 CHARS MOD -> 0 }T 613 | T{ 1S BITS 10 < -> }T 614 | 615 | T{ 0 1ST ! -> }T 616 | T{ 1 1ST +! -> }T 617 | T{ 1ST @ -> 1 }T 618 | T{ -1 1ST +! 1ST @ -> 0 }T 619 | 620 | \ ------------------------------------------------------------------------ 621 | TESTING CHAR [CHAR] [ ] BL S" 622 | 623 | T{ BL -> 20 }T 624 | T{ CHAR X -> 58 }T 625 | T{ CHAR HELLO -> 48 }T 626 | T{ : GC1 [CHAR] X ; -> }T 627 | T{ : GC2 [CHAR] HELLO ; -> }T 628 | T{ GC1 -> 58 }T 629 | T{ GC2 -> 48 }T 630 | T{ : GC3 [ GC1 ] LITERAL ; -> }T 631 | T{ GC3 -> 58 }T 632 | T{ : GC4 S" XY" ; -> }T 633 | T{ GC4 SWAP DROP -> 2 }T 634 | T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T 635 | 636 | \ ------------------------------------------------------------------------ 637 | TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE 638 | 639 | T{ : GT1 123 ; -> }T 640 | T{ ' GT1 EXECUTE -> 123 }T 641 | T{ : GT2 ['] GT1 ; IMMEDIATE -> }T 642 | T{ GT2 EXECUTE -> 123 }T 643 | HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING 644 | HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING 645 | T{ GT1STRING FIND -> ' GT1 -1 }T 646 | T{ GT2STRING FIND -> ' GT2 1 }T 647 | ( HOW TO SEARCH FOR NON-EXISTENT WORD? ) 648 | T{ : GT3 GT2 LITERAL ; -> }T 649 | T{ GT3 -> ' GT1 }T 650 | T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T 651 | 652 | T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T 653 | T{ : GT5 GT4 ; -> }T 654 | T{ GT5 -> 123 }T 655 | T{ : GT6 345 ; IMMEDIATE -> }T 656 | T{ : GT7 POSTPONE GT6 ; -> }T 657 | T{ GT7 -> 345 }T 658 | 659 | T{ : GT8 STATE @ ; IMMEDIATE -> }T 660 | T{ GT8 -> 0 }T 661 | T{ : GT9 GT8 LITERAL ; -> }T 662 | T{ GT9 0= -> }T 663 | 664 | \ ------------------------------------------------------------------------ 665 | TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE 666 | 667 | T{ : GI1 IF 123 THEN ; -> }T 668 | T{ : GI2 IF 123 ELSE 234 THEN ; -> }T 669 | T{ 0 GI1 -> }T 670 | T{ 1 GI1 -> 123 }T 671 | T{ -1 GI1 -> 123 }T 672 | T{ 0 GI2 -> 234 }T 673 | T{ 1 GI2 -> 123 }T 674 | T{ -1 GI1 -> 123 }T 675 | 676 | T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T 677 | T{ 0 GI3 -> 0 1 2 3 4 5 }T 678 | T{ 4 GI3 -> 4 5 }T 679 | T{ 5 GI3 -> 5 }T 680 | T{ 6 GI3 -> 6 }T 681 | 682 | T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T 683 | T{ 3 GI4 -> 3 4 5 6 }T 684 | T{ 5 GI4 -> 5 6 }T 685 | T{ 6 GI4 -> 6 7 }T 686 | 687 | T{ : GI5 BEGIN DUP 2 > 688 | WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T 689 | T{ 1 GI5 -> 1 345 }T 690 | T{ 2 GI5 -> 2 345 }T 691 | T{ 3 GI5 -> 3 4 5 123 }T 692 | T{ 4 GI5 -> 4 5 123 }T 693 | T{ 5 GI5 -> 5 123 }T 694 | 695 | T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T 696 | T{ 0 GI6 -> 0 }T 697 | T{ 1 GI6 -> 0 1 }T 698 | T{ 2 GI6 -> 0 1 2 }T 699 | T{ 3 GI6 -> 0 1 2 3 }T 700 | T{ 4 GI6 -> 0 1 2 3 4 }T 701 | 702 | \ ------------------------------------------------------------------------ 703 | TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT 704 | 705 | T{ : GD1 DO I LOOP ; -> }T 706 | T{ 4 1 GD1 -> 1 2 3 }T 707 | T{ 2 -1 GD1 -> -1 0 1 }T 708 | T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T 709 | 710 | T{ : GD2 DO I -1 +LOOP ; -> }T 711 | T{ 1 4 GD2 -> 4 3 2 1 }T 712 | T{ -1 2 GD2 -> 2 1 0 -1 }T 713 | T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T 714 | 715 | T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T 716 | T{ 4 1 GD3 -> 1 2 3 }T 717 | T{ 2 -1 GD3 -> -1 0 1 }T 718 | T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T 719 | 720 | T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T 721 | T{ 1 4 GD4 -> 4 3 2 1 }T 722 | T{ -1 2 GD4 -> 2 1 0 -1 }T 723 | T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T 724 | 725 | T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T 726 | T{ 1 GD5 -> 123 }T 727 | T{ 5 GD5 -> 123 }T 728 | T{ 6 GD5 -> 234 }T 729 | 730 | T{ : GD6 ( PAT: T{0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} ) 731 | 0 SWAP 0 DO 732 | I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP 733 | LOOP ; -> }T 734 | T{ 1 GD6 -> 1 }T 735 | T{ 2 GD6 -> 3 }T 736 | T{ 3 GD6 -> 4 1 2 }T 737 | 738 | T{ : GD7 1 0 DO LEAVE 1 0 DO LOOP 1 LOOP ; -> }T 739 | T{ GD7 -> }T 740 | 741 | \ ------------------------------------------------------------------------ 742 | TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY 743 | 744 | T{ 123 CONSTANT X123 -> }T 745 | T{ X123 -> 123 }T 746 | T{ : EQU CONSTANT ; -> }T 747 | T{ X123 EQU Y123 -> }T 748 | T{ Y123 -> 123 }T 749 | 750 | T{ VARIABLE V1 -> }T 751 | T{ 123 V1 ! -> }T 752 | T{ V1 @ -> 123 }T 753 | 754 | T{ : NOP : POSTPONE ; ; -> }T 755 | T{ NOP NOP1 NOP NOP2 -> }T 756 | T{ NOP1 -> }T 757 | T{ NOP2 -> }T 758 | 759 | T{ : DOES1 DOES> @ 1 + ; -> }T 760 | T{ : DOES2 DOES> @ 2 + ; -> }T 761 | T{ CREATE CR1 -> }T 762 | T{ CR1 -> HERE }T 763 | T{ ' CR1 >BODY -> HERE }T 764 | T{ 1 , -> }T 765 | T{ CR1 @ -> 1 }T 766 | T{ DOES1 -> }T 767 | T{ CR1 -> 2 }T 768 | T{ DOES2 -> }T 769 | T{ CR1 -> 3 }T 770 | 771 | T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T 772 | T{ WEIRD: W1 -> }T 773 | T{ ' W1 >BODY -> HERE }T 774 | T{ W1 -> HERE 1 + }T 775 | T{ W1 -> HERE 2 + }T 776 | 777 | \ ------------------------------------------------------------------------ 778 | TESTING EVALUATE 779 | 780 | : GE1 S" 123" ; IMMEDIATE 781 | : GE2 S" 123 1+" ; IMMEDIATE 782 | : GE3 S" : GE4 345 ;" ; 783 | : GE5 EVALUATE ; IMMEDIATE 784 | 785 | T{ GE1 EVALUATE -> 123 }T ( TEST EVALUATE IN INTERP. STATE ) 786 | T{ GE2 EVALUATE -> 124 }T 787 | T{ GE3 EVALUATE -> }T 788 | T{ GE4 -> 345 }T 789 | 790 | T{ : GE6 GE1 GE5 ; -> }T ( TEST EVALUATE IN COMPILE STATE ) 791 | T{ GE6 -> 123 }T 792 | T{ : GE7 GE2 GE5 ; -> }T 793 | T{ GE7 -> 124 }T 794 | 795 | \ ------------------------------------------------------------------------ 796 | TESTING SOURCE >IN WORD 797 | 798 | : GS1 S" SOURCE" 2DUP EVALUATE 799 | >R SWAP >R = R> R> = ; 800 | T{ GS1 -> }T 801 | 802 | VARIABLE SCANS 803 | : RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ; 804 | 805 | T{ 2 SCANS ! 806 | 345 RESCAN? 807 | -> 345 345 }T 808 | 809 | : GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ; 810 | T{ GS2 -> 123 123 123 123 123 }T 811 | 812 | : GS3 WORD COUNT SWAP C@ ; 813 | T{ BL GS3 HELLO -> 5 CHAR H }T 814 | T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T 815 | T{ BL GS3 816 | DROP -> 0 }T \ BLANK LINE RETURN ZERO-LENGTH STRING 817 | 818 | : GS4 SOURCE >IN ! DROP ; 819 | T{ GS4 123 456 820 | -> }T 821 | 822 | \ ------------------------------------------------------------------------ 823 | TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL 824 | 825 | : S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. 826 | >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH 827 | R> ?DUP IF \ IF NON-EMPTY STRINGS 828 | 0 DO 829 | OVER C@ OVER C@ - IF 2DROP UNLOOP EXIT THEN 830 | SWAP CHAR+ SWAP CHAR+ 831 | LOOP 832 | THEN 833 | 2DROP \ IF WE GET HERE, STRINGS MATCH 834 | ELSE 835 | R> DROP 2DROP \ LENGTHS MISMATCH 836 | THEN ; 837 | 838 | : GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; 839 | T{ GP1 -> }T 840 | 841 | : GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; 842 | T{ GP2 -> }T 843 | 844 | : GP3 <# 1 0 # # #> S" 01" S= ; 845 | T{ GP3 -> }T 846 | 847 | : GP4 <# 1 0 #S #> S" 1" S= ; 848 | T{ GP4 -> }T 849 | 850 | 24 CONSTANT MAX-BASE \ BASE 2 .. 36 851 | : COUNT-BITS 852 | 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; 853 | COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD 854 | 855 | : GP5 856 | BASE @ 857 | MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE 858 | I BASE ! \ TBD: ASSUMES BASE WORKS 859 | I 0 <# #S #> S" 10" S= AND 860 | LOOP 861 | SWAP BASE ! ; 862 | T{ GP5 -> }T 863 | 864 | : GP6 865 | BASE @ >R 2 BASE ! 866 | MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY 867 | R> BASE ! \ S: C-ADDR U 868 | DUP #BITS-UD = SWAP 869 | 0 DO \ S: C-ADDR FLAG 870 | OVER C@ [CHAR] 1 = AND \ ALL ONES 871 | >R CHAR+ R> 872 | LOOP SWAP DROP ; 873 | T{ GP6 -> }T 874 | 875 | : GP7 876 | BASE @ >R MAX-BASE BASE ! 877 | 878 | A 0 DO 879 | I 0 <# #S #> 880 | 1 = SWAP C@ I 30 + = AND AND 881 | LOOP 882 | MAX-BASE A DO 883 | I 0 <# #S #> 884 | 1 = SWAP C@ 41 I A - + = AND AND 885 | LOOP 886 | R> BASE ! ; 887 | 888 | T{ GP7 -> }T 889 | 890 | \ >NUMBER TESTS 891 | CREATE GN-BUF 0 C, 892 | : GN-STRING GN-BUF 1 ; 893 | : GN-CONSUMED GN-BUF CHAR+ 0 ; 894 | : GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; 895 | 896 | T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T 897 | T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T 898 | T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T 899 | T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T \ SHOULD FAIL TO CONVERT THESE 900 | T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T 901 | T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T 902 | 903 | : >NUMBER-BASED 904 | BASE @ >R BASE ! >NUMBER R> BASE ! ; 905 | 906 | T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T 907 | T{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }T 908 | T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T 909 | T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T 910 | T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T 911 | T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T 912 | 913 | : GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO. 914 | BASE @ >R BASE ! 915 | <# #S #> 916 | 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY 917 | R> BASE ! ; 918 | T{ 0 0 2 GN1 -> 0 0 0 }T 919 | T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T 920 | T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T 921 | T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T 922 | T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T 923 | T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T 924 | 925 | : GN2 \ ( -- 16 10 ) 926 | BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; 927 | T{ GN2 -> 10 A }T 928 | 929 | \ ------------------------------------------------------------------------ 930 | TESTING FILL MOVE 931 | 932 | CREATE FBUF 00 C, 00 C, 00 C, 933 | CREATE SBUF 12 C, 34 C, 56 C, 934 | : SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; 935 | 936 | T{ FBUF 0 20 FILL -> }T 937 | T{ SEEBUF -> 00 00 00 }T 938 | 939 | T{ FBUF 1 20 FILL -> }T 940 | T{ SEEBUF -> 20 00 00 }T 941 | 942 | T{ FBUF 3 20 FILL -> }T 943 | T{ SEEBUF -> 20 20 20 }T 944 | 945 | T{ FBUF FBUF 3 CHARS MOVE -> }T \ BIZARRE SPECIAL CASE 946 | T{ SEEBUF -> 20 20 20 }T 947 | 948 | T{ SBUF FBUF 0 CHARS MOVE -> }T 949 | T{ SEEBUF -> 20 20 20 }T 950 | 951 | T{ SBUF FBUF 1 CHARS MOVE -> }T 952 | T{ SEEBUF -> 12 20 20 }T 953 | 954 | T{ SBUF FBUF 3 CHARS MOVE -> }T 955 | T{ SEEBUF -> 12 34 56 }T 956 | 957 | T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T 958 | T{ SEEBUF -> 12 12 34 }T 959 | 960 | T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T 961 | T{ SEEBUF -> 12 34 34 }T 962 | 963 | \ ------------------------------------------------------------------------ 964 | TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U. 965 | 966 | : OUTPUT-TEST 967 | ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR 968 | 41 BL DO I EMIT LOOP CR 969 | 61 41 DO I EMIT LOOP CR 970 | 7F 61 DO I EMIT LOOP CR 971 | ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR 972 | 9 1+ 0 DO I . LOOP CR 973 | ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR 974 | [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR 975 | ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR 976 | [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR 977 | ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR 978 | 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR 979 | ." YOU SHOULD SEE TWO SEPARATE LINES:" CR 980 | S" LINE 1" TYPE CR S" LINE 2" TYPE CR 981 | ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR 982 | ." SIGNED: " MIN-INT . MAX-INT . CR 983 | ." UNSIGNED: " 0 U. MAX-UINT U. CR 984 | ; 985 | 986 | T{ OUTPUT-TEST -> }T 987 | 988 | 989 | \ ------------------------------------------------------------------------ 990 | TESTING INPUT: ACCEPT 991 | 992 | CREATE ABUF 50 CHARS ALLOT 993 | 994 | : ACCEPT-TEST 995 | CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR 996 | ABUF 50 ACCEPT 997 | CR ." RECEIVED: " [CHAR] " EMIT 998 | ABUF SWAP TYPE [CHAR] " EMIT CR 999 | ; 1000 | 1001 | T{ ACCEPT-TEST -> }T 1002 | 1003 | \ ------------------------------------------------------------------------ 1004 | TESTING DICTIONARY SEARCH RULES 1005 | 1006 | T{ : GDX 123 ; : GDX GDX 234 ; -> }T 1007 | 1008 | T{ GDX -> 123 234 }T 1009 | 1010 | CR .( End of Core word set tests) CR 1011 | 1012 | 1013 | 1014 | -------------------------------------------------------------------------------- /acmeforth: -------------------------------------------------------------------------------- 1 | #!/usr/bin/python3 2 | 3 | DEBUG = 0 4 | 5 | import ctypes 6 | import dictionary 7 | import os 8 | import readline 9 | import sys 10 | import xc 11 | 12 | class Word: 13 | def __init__(self, name, xt, immediate): 14 | self.name = name 15 | self.xt = xt 16 | self.body = None # points to the first cell to execute as part of the word 17 | self.body_end = None # points to the cell after the ; exit 18 | self.immediate = immediate 19 | 20 | @property 21 | def xt(self): 22 | return self.__xt 23 | 24 | @xt.setter 25 | def xt(self, xt): 26 | self.__xt = xt 27 | assert xt not in dictionary.xt_words 28 | dictionary.xt_words[xt] = self 29 | 30 | def __repr__(self): 31 | return self.name 32 | 33 | class Stack: 34 | stack_underflow_area = [-1] * 32 35 | def __init__(self): 36 | self.stack = self.stack_underflow_area.copy() 37 | 38 | def append(self, val): 39 | self.stack.append(val) 40 | 41 | def pop(self): 42 | if len(stack) == 0: 43 | print("Stack underflow") 44 | ABORT() 45 | val = self.stack.pop() 46 | if type(val) == str: val = ord(val) 47 | return val 48 | 49 | def getchar(self): 50 | return self.stack[-1] 51 | 52 | def __len__(self): 53 | return len(self.stack) - 32 54 | 55 | def __getitem__(self, i): 56 | c = self.stack[i] 57 | return ord(c) if type(c) == str else c 58 | 59 | def __setitem__(self, i, val): 60 | assert type(val) == int or type(val) == str or callable(val) or type(val) == xc.Ref 61 | self.stack[i] = val 62 | 63 | def __repr__(self): 64 | return str(self.stack[32:]) 65 | 66 | class Heap: 67 | def __init__(self, size): 68 | self.heap = [0] * size 69 | 70 | def __getitem__(self, i): 71 | c = self.heap[i] 72 | return ord(c) if type(c) == str else c 73 | 74 | def getchar(self, i): 75 | return self.heap[i] 76 | 77 | def __setitem__(self, i, val): 78 | assert type(val) == int or type(val) == str or callable(val) or type(val) == xc.Ref 79 | self.heap[i] = val 80 | 81 | def __len__(self): 82 | return len(self.heap) 83 | 84 | dictionary = dictionary.Dictionary() 85 | stack = Stack() 86 | return_stack = [] 87 | leave_stack = [] 88 | tib_count = 0 89 | ip = 0 90 | 91 | # Forth variable space. 92 | to_in_addr = 0 93 | state_addr = to_in_addr + 2 94 | word_addr = state_addr + 2 95 | pictured_numeric_addr = word_addr + 40 96 | tib_addr = pictured_numeric_addr + 70 97 | original_tib_addr = tib_addr 98 | here = tib_addr + 200 99 | 100 | heap = Heap(65536) 101 | 102 | digits = "0123456789abcdefghijklmnopqrstuvwxyz" 103 | 104 | def append(val): 105 | global here 106 | heap[here] = val 107 | here += 1 108 | if raw_data_word: 109 | raw_data_word.body_end = here 110 | 111 | def set_state(flag): 112 | v = 0xff if flag else 0 113 | heap[state_addr] = v 114 | heap[state_addr + 1] = v 115 | 116 | def STATE(): 117 | stack.append(state_addr) 118 | 119 | def TO_IN(): 120 | stack.append(to_in_addr) 121 | 122 | def add_word(name, xt, immediate = False): 123 | dictionary.words[name] = Word(name, xt, immediate) 124 | 125 | def get_base(): 126 | if "base" in dictionary.words: 127 | execute("base") 128 | base_addr = stack.pop() 129 | base = heap[base_addr] 130 | if not base: 131 | base = 10 132 | return base 133 | 134 | def is_number(word): 135 | base = get_base() 136 | if word[0] == "#": 137 | base = 10 138 | word = word[1:] 139 | if not word: 140 | return False 141 | elif word[0] == "$": 142 | base = 16 143 | word = word[1:] 144 | if not word: 145 | return False 146 | elif word[0] == "%": 147 | base = 2 148 | word = word[1:] 149 | if not word: 150 | return False 151 | elif len(word) == 3 and word[0] == "'" and word[2] == "'": 152 | return True 153 | if word[0] == '-': 154 | word = word[1:] 155 | if not word: 156 | return False 157 | for d in word.lower(): 158 | if d not in digits: 159 | return False 160 | if digits.index(d) >= base: 161 | return False 162 | return True 163 | 164 | def evaluate_number(word): 165 | global stack 166 | number = 0 167 | base = get_base() 168 | if word[0] == "#": 169 | base = 10 170 | word = word[1:] 171 | elif word[0] == "$": 172 | base = 16 173 | word = word[1:] 174 | elif word[0] == "%": 175 | base = 2 176 | word = word[1:] 177 | elif word[0] == "'": 178 | stack.append(word[1]) 179 | return 180 | negate = word[0] == '-' 181 | if negate: 182 | word = word[1:] 183 | for d in word.lower(): 184 | number *= base 185 | number += digits.index(d) 186 | if negate: 187 | number = -number 188 | stack.append(ctypes.c_short(number).value) 189 | 190 | def execute(word_name): 191 | dictionary.words[word_name].xt() 192 | 193 | def ABORT(): 194 | execute("abort") 195 | 196 | def evaluate(word): 197 | global stack 198 | if word.lower() in dictionary.words: 199 | word = dictionary.words[word.lower()] 200 | word.xt() 201 | else: 202 | if is_number(word): 203 | evaluate_number(word) 204 | else: 205 | print("Undefined word", word) 206 | ABORT() 207 | 208 | def SOURCE_ID(): 209 | if tib_addr != original_tib_addr: 210 | stack.append(-1) # evaluate 211 | elif INPUT_FILE: 212 | stack.append(INPUT_FILE) # file 213 | else: 214 | stack.append(0) # console 215 | 216 | def REFILL(): 217 | global INPUT_FILE 218 | global tib_count 219 | 220 | SOURCE_ID() 221 | source_id = stack.pop() 222 | if source_id == -1: # evaluated string 223 | stack.append(0) 224 | elif source_id == 0: # reading from console 225 | tib_count = 0 226 | for c in input(): 227 | heap[tib_addr + tib_count] = c 228 | tib_count += 1 229 | heap[to_in_addr] = 0 230 | stack.append(-1) 231 | else: 232 | l = source_id.readline() 233 | if l: 234 | l = l.rstrip() 235 | if DEBUG: 236 | print(l) 237 | tib_count = len(l) 238 | for i in range(tib_count): 239 | heap[tib_addr + i] = l[i] 240 | heap[to_in_addr] = 0 241 | stack.append(-1) 242 | else: # EOF 243 | stack.append(0) 244 | INPUT_FILE = None 245 | 246 | def parse(delimiter): 247 | assert type(delimiter) == str 248 | delimiter_is_space = delimiter == ' ' 249 | 250 | to_in = heap[to_in_addr] 251 | 252 | # skips leading whitespace 253 | while to_in < tib_count: 254 | if heap.getchar(tib_addr + to_in).isspace(): 255 | to_in += 1 256 | else: 257 | break 258 | 259 | # reads the word 260 | word = "" 261 | while to_in < tib_count: 262 | c = heap.getchar(tib_addr + to_in) 263 | to_in += 1 264 | if delimiter_is_space and c.isspace(): 265 | break 266 | elif c == delimiter: 267 | break 268 | word += c 269 | 270 | heap[to_in_addr] = to_in 271 | 272 | return word 273 | 274 | def read_word(): 275 | while True: 276 | return parse(' ') 277 | if word: 278 | return word 279 | REFILL() 280 | stack.pop() 281 | 282 | def CREATE(): 283 | global raw_data_word 284 | dictionary.latest = read_word().lower() 285 | previous_word = None 286 | if dictionary.latest in dictionary.words: 287 | previous_word = dictionary.words[dictionary.latest] 288 | SOURCE_ID() 289 | if stack.pop() == 0: 290 | print("redefined " + previous_word.name) 291 | dictionary.words[dictionary.latest] = Word(dictionary.latest, lambda l=here : stack.append(xc.Ref(l)), False) 292 | dictionary.words[dictionary.latest].body = here 293 | dictionary.words[dictionary.latest].body_end = here 294 | raw_data_word = dictionary.words[dictionary.latest] 295 | return previous_word 296 | 297 | def VARIABLE(): 298 | CREATE() 299 | stack.append(0) 300 | COMMA() 301 | 302 | def compile(word): 303 | global stack 304 | words = dictionary.words 305 | if word.lower() in dictionary.words: 306 | word = word.lower() 307 | if dictionary.words[word].immediate: 308 | execute(word) 309 | else: 310 | append(dictionary.words[word].xt) 311 | else: 312 | if word in dictionary.code_words: 313 | w = Word(word, lambda word=word : sys.exit("code word " + word), False) 314 | append(w.xt) 315 | elif is_number(word): 316 | evaluate_number(word) 317 | val = stack.getchar() 318 | if type(val) == int and val & 0xff00: 319 | append(dictionary.words["lit"].xt) 320 | COMMA() 321 | else: 322 | append(dictionary.words["litc"].xt) 323 | C_COMMA() 324 | else: 325 | print("Undefined word", word) 326 | ABORT() 327 | 328 | def interpret_tib(): 329 | while heap[to_in_addr] <= tib_count: 330 | word = read_word() 331 | if not word: 332 | return 333 | if heap[state_addr]: 334 | if DEBUG: 335 | print("COMPILE", word) 336 | compile(word) 337 | else: 338 | if DEBUG: 339 | print("EVALUATE", word) 340 | evaluate(word) 341 | if DEBUG: 342 | print("stack", stack) 343 | 344 | def C_STORE(): 345 | dst = stack[-1] 346 | v = stack[-2] 347 | heap[dst] = v & 0xff 348 | execute("2drop") 349 | 350 | def STORE(): 351 | dst = stack[-1] 352 | if type(dst) == xc.Ref: 353 | dst = dst.addr 354 | v = stack[-2] 355 | if type(v) == xc.Ref: 356 | v = v.addr 357 | if type(v) == type(0): 358 | heap[dst] = v & 0xff 359 | heap[dst + 1] = v >> 8 360 | elif callable(v): 361 | heap[dst] = v 362 | heap[dst + 1] = 0 363 | else: 364 | assert False 365 | DROP() 366 | DROP() 367 | 368 | def PLUSSTORE(): 369 | heap[stack.pop()] += stack.pop() 370 | 371 | def docol(ip_): 372 | global ip 373 | return_stack.append(ip) 374 | ip = ip_ 375 | while ip: 376 | code = heap[ip] 377 | ip += 1 378 | if callable(code): 379 | if DEBUG: 380 | print("exec", code, ip) 381 | if code(): 382 | return 383 | if DEBUG: 384 | print(stack, ip) 385 | else: 386 | stack.append(code) 387 | 388 | def DEPTH(): 389 | stack.append(len(stack)) 390 | 391 | compiling_word = None 392 | 393 | def COLON(): 394 | global compiling_word 395 | global raw_data_word 396 | old_word = CREATE() 397 | compiling_word = dictionary.words[dictionary.latest] 398 | raw_data_word = None 399 | dictionary.words[dictionary.latest] = old_word 400 | compiling_word.xt = lambda ip = compiling_word.body : docol(ip) 401 | set_state(True) 402 | 403 | def SEMICOLON(): 404 | global compiling_word 405 | append(dictionary.words["exit"].xt) 406 | set_state(False) 407 | if compiling_word: 408 | dictionary.words[dictionary.latest] = compiling_word 409 | compiling_word.body_end = here 410 | compiling_word = None 411 | 412 | def DROP(): 413 | stack.pop() 414 | 415 | def TWODROP(): 416 | DROP() 417 | DROP() 418 | 419 | def DUP(): 420 | stack.append(stack[-1]) 421 | 422 | def TWODUP(): 423 | stack.append(stack[-2]) 424 | stack.append(stack[-2]) 425 | 426 | def OVER(): 427 | stack.append(stack[-2]) 428 | 429 | def PICK(): 430 | stack.append(stack[-stack.pop()-1]) 431 | 432 | def ROT(): 433 | stack[-1], stack[-2], stack[-3] = stack[-3], stack[-1], stack[-2] 434 | 435 | def SWAP(): 436 | stack[-1], stack[-2] = stack[-2], stack[-1] 437 | 438 | def BRANCH(): 439 | global ip 440 | if type(heap[ip]) == xc.Ref: 441 | ip = heap[ip].addr 442 | else: 443 | ip = heap[ip] + (heap[ip + 1] << 8) 444 | 445 | def ZBRANCH(): 446 | global ip 447 | if stack.pop(): 448 | ip += 2 449 | else: 450 | BRANCH() 451 | 452 | def ELSE(): 453 | append(dictionary.words["branch"].xt) 454 | stack.append(0) 455 | COMMA() 456 | heap[stack[-1]] = xc.Ref(here) 457 | stack[-1] = here - 2 458 | 459 | def THEN(): 460 | heap[stack[-1]] = here & 0xff 461 | heap[stack[-1] + 1] = here >> 8 462 | stack.pop() 463 | 464 | def ZERO_LT(): 465 | stack[-1] = -1 if stack[-1] < 0 else 0 466 | 467 | def QUIT(): 468 | global tib_addr 469 | return_stack.clear() 470 | tib_addr = original_tib_addr 471 | 472 | if INPUT_FILE: 473 | sys.exit(1) 474 | 475 | while True: 476 | REFILL() 477 | stack.pop() 478 | interpret_tib() 479 | SOURCE_ID() 480 | if stack.pop() == 0: 481 | print(" compiled" if heap[state_addr] else " ok") 482 | 483 | def J(): 484 | stack.append(return_stack[-3]) 485 | 486 | def DO(): 487 | append(dictionary.words["(do)"].xt) 488 | stack.append(here) 489 | 490 | def _DO(): 491 | SWAP() 492 | TO_R() # limit 493 | TO_R() # index 494 | 495 | def _QUESTION_DO(): 496 | global ip 497 | TWODUP() 498 | EQUALS() 499 | if stack.pop(): 500 | # Don't enter loop. 501 | execute("2drop") 502 | BRANCH() 503 | else: 504 | # Enter loop. 505 | _DO() 506 | ip += 2 507 | 508 | def QUESTION_DO(): 509 | append(dictionary.words["(?do)"].xt) 510 | leave_stack.append(here) 511 | stack.append(0) 512 | COMMA() 513 | stack.append(here) 514 | 515 | def resolve_leaves(): 516 | while leave_stack: 517 | assert stack 518 | # The additional -1 is for ?DO, which has a cell between (?DO) and the loop body. 519 | if leave_stack[-1] < stack[-1] - 2: 520 | break 521 | dst = leave_stack.pop() 522 | heap[dst] = xc.Ref(here) 523 | 524 | def LOOP(): 525 | append(dictionary.words["(loop)"].xt) 526 | DUP() 527 | COMMA() 528 | resolve_leaves() 529 | stack.pop() 530 | 531 | def _LOOP(): 532 | global ip 533 | return_stack[-1] = ctypes.c_short(return_stack[-1] + 1).value 534 | if return_stack[-2] == return_stack[-1]: 535 | return_stack.pop() 536 | return_stack.pop() 537 | ip += 2 538 | else: 539 | ip = heap[ip] + (heap[ip + 1] << 8) 540 | 541 | def LEAVE(): 542 | UNLOOP() 543 | append(dictionary.words["branch"].xt) 544 | leave_stack.append(here) 545 | stack.append(0) 546 | COMMA() 547 | 548 | def UNLOOP(): 549 | append(dictionary.words["r>"].xt) 550 | append(dictionary.words["r>"].xt) 551 | append(dictionary.words["2drop"].xt) 552 | 553 | # forth-standard.org 554 | def WITHIN(): # ( test lower upper -- flag ) 555 | OVER() 556 | MINUS() 557 | TO_R() 558 | MINUS() 559 | R_TO() 560 | U_LESS() 561 | 562 | def PLUSLOOP(): 563 | append(dictionary.words["(+loop)"].xt) 564 | DUP() 565 | COMMA() 566 | resolve_leaves() 567 | stack.pop() 568 | 569 | def _PLUSLOOP(): 570 | global ip 571 | increment = stack.pop() 572 | if not increment: 573 | ip = heap[ip] + (heap[ip + 1] << 8) 574 | return 575 | pre_increment = return_stack[-1] 576 | return_stack[-1] = ctypes.c_short(return_stack[-1] + increment).value 577 | post_increment = return_stack[-1] 578 | test_value = return_stack[-2] - 1 579 | stack.append(test_value) 580 | if increment > 0: 581 | stack.append(pre_increment) 582 | stack.append(post_increment) 583 | else: 584 | stack.append(post_increment) 585 | stack.append(pre_increment) 586 | # crossed limit? 587 | WITHIN() 588 | if stack.pop(): 589 | # yes, exit loop 590 | return_stack.pop() 591 | return_stack.pop() 592 | ip += 2 593 | else: 594 | # no, iterate 595 | ip = heap[ip] + (heap[ip + 1] << 8) 596 | 597 | def CR(): 598 | print() 599 | 600 | def ALLOT(): 601 | global here 602 | here += stack.pop() 603 | if raw_data_word: 604 | raw_data_word.body_end = here 605 | 606 | def SLITERAL(): 607 | global ip 608 | stack.append(ip + 1) 609 | stack.append(heap[ip]) 610 | ip += heap[ip] + 1 611 | 612 | def S_QUOTE(): 613 | s = "" 614 | while heap[to_in_addr] < tib_count: 615 | c = heap[tib_addr + heap[to_in_addr]] 616 | heap[to_in_addr] += 1 617 | if c == ord('"'): 618 | break 619 | s += chr(c) 620 | append(dictionary.words["sliteral"].xt) 621 | append(len(s)) 622 | for c in s: 623 | append(c) 624 | 625 | def S_BACKSLASH_QUOTE(): 626 | s = "" 627 | while heap[to_in_addr] < tib_count: 628 | c = heap[tib_addr + heap[to_in_addr]] 629 | heap[to_in_addr] += 1 630 | if c == ord('\\'): 631 | c = heap[tib_addr + heap[to_in_addr]] 632 | heap[to_in_addr] += 1 633 | l = [] 634 | if c == ord('a'): l = [7] 635 | elif c == ord('b'): l = [8] 636 | elif c == ord('e'): l = [27] 637 | elif c == ord('f'): l = [12] 638 | elif c == ord('l'): l = [10] 639 | elif c == ord('m'): l = [13, 10] 640 | elif c == ord('n'): l = [xc.NEWLINE] 641 | elif c == ord('q'): l = [34] 642 | elif c == ord('r'): l = [13] 643 | elif c == ord('t'): l = [9] 644 | elif c == ord('v'): l = [11] 645 | elif c == ord('z'): l = [0] 646 | elif c == ord('"'): l = [34] 647 | elif c == ord('\\'): l = [92] 648 | elif c == ord('x'): 649 | msd = digits.index(chr(heap[tib_addr + heap[to_in_addr]]).lower()) 650 | heap[to_in_addr] += 1 651 | lsd = digits.index(chr(heap[tib_addr + heap[to_in_addr]]).lower()) 652 | heap[to_in_addr] += 1 653 | s += chr(msd * 16 + lsd) 654 | for c in l: 655 | s += chr(c) 656 | elif c == ord('"'): 657 | break 658 | else: 659 | s += chr(c) 660 | 661 | append(dictionary.words["sliteral"].xt) 662 | append(len(s)) 663 | for c in s: 664 | append(c) 665 | 666 | def C_QUOTE(): 667 | S_QUOTE() 668 | append(dictionary.words["drop"].xt) 669 | append(dictionary.words["1-"].xt) 670 | 671 | def FETCH(): 672 | src = stack[-1] 673 | if type(src) == xc.Ref: 674 | src = src.addr 675 | v = heap[src] 676 | if type(v) == type(0): 677 | v += heap[src + 1] << 8 678 | stack[-1] = v 679 | 680 | def C_FETCH(): 681 | stack[-1] = heap[stack[-1]] 682 | 683 | def TO_R(): 684 | return_stack.append(stack.pop()) 685 | 686 | def R_TO(): 687 | stack.append(return_stack.pop()) 688 | 689 | def R_FETCH(): 690 | stack.append(return_stack[-1]) 691 | 692 | def TYPE(): 693 | for c in heap[stack[-2] : stack[-2] + stack[-1]]: 694 | stack.append(c) 695 | EMIT() 696 | execute("2drop") 697 | 698 | def EXIT(): 699 | global ip 700 | if return_stack: 701 | ip = return_stack.pop() 702 | else: 703 | ip = None 704 | return True 705 | 706 | def LPAREN(): 707 | while True: 708 | while heap[to_in_addr] < tib_count: 709 | if heap[tib_addr + heap[to_in_addr]] == ord(')'): 710 | heap[to_in_addr] += 1 711 | return 712 | heap[to_in_addr] += 1 713 | REFILL() 714 | stack.pop() 715 | 716 | def EQUALS(): 717 | stack[-2] = -1 if stack[-1] == stack[-2] else 0 718 | stack.pop() 719 | 720 | def ONEPLUS(): 721 | l = ctypes.c_short(stack[-1]) 722 | l.value += 1 723 | stack[-1] = l.value 724 | 725 | def ONEMINUS(): 726 | l = ctypes.c_short(stack[-1]) 727 | l.value -= 1 728 | stack[-1] = l.value 729 | 730 | def PLUS(): 731 | l = ctypes.c_short(stack[-2]) 732 | l.value += stack[-1] 733 | stack.pop() 734 | stack[-1] = l.value 735 | 736 | def MINUS(): 737 | l = ctypes.c_short(stack[-2]) 738 | l.value -= stack[-1] 739 | stack.pop() 740 | stack[-1] = l.value 741 | 742 | def ABS(): 743 | l = ctypes.c_short(stack[-1]) 744 | l.value = abs(l.value) 745 | stack[-1] = l.value 746 | 747 | def ZEQUAL(): 748 | stack[-1] = 0 if stack[-1] else -1 749 | 750 | def AND(): 751 | stack[-2] &= stack[-1] 752 | stack.pop() 753 | 754 | def OR(): 755 | stack[-2] |= stack[-1] 756 | stack.pop() 757 | 758 | def XOR(): 759 | stack[-2] ^= stack[-1] 760 | stack.pop() 761 | 762 | def RSHIFT(): 763 | l = ctypes.c_ushort(stack[-2]) 764 | l.value >>= stack[-1] 765 | stack.pop() 766 | stack[-1] = l.value 767 | 768 | def LSHIFT(): 769 | l = ctypes.c_short(stack[-2]) 770 | l.value <<= stack[-1] 771 | stack[-2] = l.value 772 | stack.pop() 773 | 774 | def INVERT(): 775 | stack[-1] = ~stack[-1] 776 | 777 | def CONSTANT(): 778 | global raw_data_word 779 | CREATE() 780 | v = stack.pop() 781 | dictionary.words[dictionary.latest].xt = lambda : stack.append(v) 782 | dictionary.words[dictionary.latest].constant_value = v 783 | raw_data_word = None 784 | 785 | def TWOMUL(): 786 | stack.append(1) 787 | LSHIFT() 788 | 789 | def TWODIV(): 790 | stack[-1] >>= 1 791 | 792 | def U_LESS(): 793 | if stack[-1] < 0: 794 | stack[-1] += 2 ** 16 795 | if stack[-2] < 0: 796 | stack[-2] += 2 ** 16 797 | stack[-2] = -1 if stack[-2] < stack[-1] else 0 798 | stack.pop() 799 | 800 | def LESS_THAN(): 801 | stack[-2] = -1 if stack[-2] < stack[-1] else 0 802 | stack.pop() 803 | 804 | def GREATER_THAN(): 805 | stack[-2] = -1 if stack[-2] > stack[-1] else 0 806 | stack.pop() 807 | 808 | def MULTIPLY(): 809 | v = ctypes.c_short(stack[-2]) 810 | v.value *= stack[-1] 811 | stack.pop() 812 | stack[-1] = v.value 813 | 814 | def M_MULTIPLY(): 815 | s = stack[-2] * stack[-1] 816 | stack[-1] = ctypes.c_short(s >> 16).value 817 | stack[-2] = ctypes.c_short(s).value 818 | 819 | def UM_MULTIPLY(): 820 | s = ctypes.c_ushort(stack[-2]).value * ctypes.c_ushort(stack[-1]).value 821 | stack[-1] = ctypes.c_short(s >> 16).value 822 | stack[-2] = ctypes.c_short(s).value 823 | 824 | def TUCK(): # ( b a -- a b a ) 825 | SWAP() 826 | OVER() 827 | 828 | def UM_MOD(): # ( lsw msw divisor -- rem quot ) 829 | lsw = stack[-3] 830 | msw = stack[-2] 831 | n = (ctypes.c_ushort(msw).value << 16) | ctypes.c_ushort(lsw).value 832 | d = ctypes.c_ushort(stack[-1]).value 833 | stack[-3] = ctypes.c_ushort(n % stack[-1]).value 834 | stack[-2] = ctypes.c_short(n // d).value 835 | stack.pop() 836 | 837 | def POSTPONE(): 838 | name = read_word().lower() 839 | words = dictionary.words 840 | if words[name].immediate: 841 | # Compiles the word instead of executing it immediately. 842 | append(words[name].xt) 843 | else: 844 | # Instead of compiling the word, compile code that compiles the word. 845 | append(words["litc"].xt) 846 | append(words[name].xt) 847 | append(words["compile,"].xt) 848 | 849 | raw_data_word = None 850 | 851 | def HERE(): 852 | global raw_data_word 853 | word = None 854 | if raw_data_word: 855 | word = raw_data_word 856 | elif dictionary.words[dictionary.latest] and not "CREATE" in str(dictionary.words[dictionary.latest].xt): 857 | label = "here_" + str(here) 858 | if label not in dictionary.words: 859 | raw_data_word = Word(label, lambda : None, False) 860 | raw_data_word.body = here 861 | raw_data_word.body_end = here 862 | dictionary.words[label] = raw_data_word 863 | word = raw_data_word 864 | stack.append(xc.Ref(here, word)) 865 | 866 | def COMMA(): 867 | global ip 868 | v = stack.pop() 869 | if type(v) == type(0): 870 | append(v & 0xff) 871 | append(v >> 8) 872 | else: 873 | append(v) 874 | append(0) 875 | 876 | def C_COMMA(): 877 | append(stack.getchar()) 878 | stack.pop() 879 | 880 | def WHILE(): 881 | append(dictionary.words["0branch"].xt) 882 | stack.append(here) 883 | SWAP() 884 | append(0) 885 | append(0) 886 | 887 | def REPEAT(): 888 | append(dictionary.words["branch"].xt) 889 | COMMA() 890 | orig = stack.pop() 891 | heap[orig] = here & 0xff 892 | heap[orig + 1] = here >> 8 893 | 894 | def UNTIL(): 895 | append(dictionary.words["0branch"].xt) 896 | COMMA() 897 | 898 | def AGAIN(): 899 | append(dictionary.words["branch"].xt) 900 | COMMA() 901 | 902 | def CHAR(): 903 | w = read_word() 904 | stack.append(w[0]) 905 | 906 | def COMPILE_CHAR(): 907 | w = read_word() 908 | append(LITC) 909 | append(w[0]) 910 | 911 | def TICK(): 912 | w = read_word().lower() 913 | xt = dictionary.words[w].xt 914 | stack.append(xt) 915 | 916 | def COMPILE_TICK(): 917 | TICK() 918 | LITERAL() 919 | 920 | def IMMEDIATE(): 921 | dictionary.words[dictionary.latest].immediate = True 922 | 923 | def FIND(): # ( c-addr -- c-addr 0 | xt 1 | xt -1 ) 924 | wordname = "" 925 | addr = stack[-1] 926 | for i in range(heap[addr]): 927 | wordname += chr(heap[addr + i + 1]).lower() 928 | if wordname in dictionary.words: 929 | word = dictionary.words[wordname] 930 | stack[-1] = word.xt 931 | stack.append(1 if word.immediate else -1) 932 | else: 933 | stack.append(0) 934 | 935 | def EXECUTE(): 936 | stack.pop()() 937 | 938 | def LIT(): 939 | global ip 940 | if callable(heap[ip]) or type(heap[ip]) == xc.Ref: 941 | stack.append(heap[ip]) 942 | else: 943 | stack.append(heap[ip] + (heap[ip + 1] << 8)) 944 | ip += 2 945 | 946 | def LITC(): 947 | global ip 948 | stack.append(heap.getchar(ip)) 949 | ip += 1 950 | 951 | def RECURSE(): 952 | append(compiling_word.xt) 953 | 954 | def DOES_TO(): 955 | def dodoes(code, data): 956 | stack.append(data) 957 | docol(code) 958 | w = dictionary.words[dictionary.latest] 959 | w.xt = lambda code=ip, data=w.body : dodoes(code, data) 960 | w.xt_ip = ip 961 | EXIT() 962 | 963 | def TO_BODY(): # ( xt -- a-addr ) 964 | for word in dictionary.words.values(): 965 | assert word 966 | if word.xt == stack[-1]: 967 | stack[-1] = xc.Ref(word.body) 968 | return 969 | assert False 970 | 971 | def EVALUATE(): # ( c-addr u -- ) 972 | global tib_addr 973 | global tib_count 974 | 975 | # Stash tib_addr, tib_count, >in 976 | orig_tib = tib_addr 977 | orig_tib_count = tib_count 978 | orig_to_in = heap[to_in_addr] 979 | 980 | # Set temporary tib_addr, tib_count, >in 981 | heap[to_in_addr] = 0 982 | tib_count = stack.pop() 983 | tib_addr = stack.pop() 984 | 985 | # Evaluate until tib is consumed 986 | while True: 987 | word = parse(' ') 988 | if not word: 989 | break 990 | if heap[state_addr]: 991 | compile(word) 992 | else: 993 | evaluate(word) 994 | 995 | # Restore tib_addr, tib_count, >in 996 | heap[to_in_addr] = orig_to_in 997 | tib_count = orig_tib_count 998 | tib_addr = orig_tib 999 | 1000 | def SOURCE(): # ( -- c-addr u ) 1001 | stack.append(tib_addr) 1002 | stack.append(tib_count) 1003 | 1004 | def WORD(): 1005 | w = parse(chr(stack.pop())) 1006 | l = len(w) 1007 | heap[word_addr] = l 1008 | for i in range(l): 1009 | heap[word_addr + i + 1] = w[i] 1010 | stack.append(word_addr) 1011 | 1012 | def format_append(ch): 1013 | global format_addr 1014 | heap[format_addr] = ch 1015 | format_addr += 1 1016 | 1017 | def LT_HASH(): 1018 | global format_addr 1019 | format_addr = here 1020 | 1021 | def HOLD(): # ( char -- ) 1022 | format_append(stack.pop()) 1023 | 1024 | def SIGN(): # ( i -- ) 1025 | if stack.pop() < 0: 1026 | format_append('-') 1027 | 1028 | def HASH(): # ( ud1 -- ud2 ) 1029 | d = ctypes.c_uint(stack[-1] << 16) 1030 | d.value += ctypes.c_ushort(stack[-2]).value 1031 | format_append(digits[d.value % get_base()].upper()) 1032 | d.value //= get_base() 1033 | stack[-2] = d.value & 0xffff 1034 | stack[-1] = d.value >> 16 1035 | 1036 | def HASH_S(): # ( ud1 -- ud2 ) 1037 | HASH() 1038 | while stack[-1] or stack[-2]: 1039 | HASH() 1040 | 1041 | def RT_HASH(): # ( xd -- c-addr u ) 1042 | global format_addr 1043 | execute("2drop") 1044 | stack.append(pictured_numeric_addr) 1045 | stack.append(format_addr - here) 1046 | dst = pictured_numeric_addr 1047 | format_addr -= 1 1048 | while format_addr >= here: 1049 | heap[dst] = heap[format_addr] 1050 | dst += 1 1051 | format_addr -= 1 1052 | 1053 | def TO_NUMBER(): # ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) 1054 | while stack[-1]: 1055 | c = chr(heap[stack[-2]]).lower() 1056 | if c not in digits: 1057 | break 1058 | i = digits.index(c) 1059 | if i == -1 or i >= get_base(): 1060 | break 1061 | 1062 | # Accumulate i to ud. 1063 | ud = ctypes.c_uint(stack[-3]) 1064 | ud.value <<= 16 1065 | ud.value += ctypes.c_ushort(stack[-4]).value 1066 | ud.value *= get_base() 1067 | ud.value += i 1068 | stack[-4] = ctypes.c_short(ud.value & 0xffff).value 1069 | stack[-3] = ctypes.c_short(ud.value >> 16).value 1070 | 1071 | ONEMINUS() 1072 | SWAP() 1073 | ONEPLUS() 1074 | SWAP() 1075 | 1076 | def FILL(): # ( c-addr u char -- ) 1077 | while stack[-2]: 1078 | heap[stack[-3]] = stack[-1] 1079 | stack[-2] -= 1 1080 | stack[-3] += 1 1081 | execute("2drop") 1082 | DROP() 1083 | 1084 | def MOVE(): # ( src dst u -- ) 1085 | tmp = heap[stack[-3] : stack[-3] + stack[-1]] 1086 | for i in range(len(tmp)): 1087 | heap[stack[-2] + i] = tmp[i] 1088 | execute("2drop") 1089 | DROP() 1090 | 1091 | def DOT_QUOTE(): 1092 | S_QUOTE() 1093 | append(dictionary.words["type"].xt) 1094 | 1095 | def SPACE(): 1096 | print(" ", end='') 1097 | 1098 | def EMIT(): 1099 | c = stack.pop() 1100 | if c == xc.NEWLINE: 1101 | c = '\n' 1102 | else: 1103 | c = chr(c) 1104 | print(c, end='') 1105 | 1106 | def DABS(): 1107 | d = ctypes.c_int(stack[-1]) 1108 | d.value <<= 16 1109 | d.value |= ctypes.c_ushort(stack[-2]).value 1110 | d.value = abs(d.value) 1111 | stack[-1] = d.value >> 16 1112 | stack[-2] = d.value & 0xffff 1113 | 1114 | def ACCEPT(): # ( c-addr n1 -- n2 ) 1115 | s = input() 1116 | l = min(len(s), stack[-1]) 1117 | for i in range(l): 1118 | heap[stack[-2] + i] = s[i] 1119 | stack.pop() 1120 | stack[-1] = l 1121 | 1122 | def DOT_LPAREN(): 1123 | print(parse(')'), end='') 1124 | 1125 | noname_counter = 0 1126 | def COLON_NONAME(): 1127 | global compiling_word 1128 | global noname_counter 1129 | global raw_data_word 1130 | dictionary.latest = "_:NONAME" + str(noname_counter) 1131 | noname_counter += 1 1132 | ip = here 1133 | compiling_word = Word(dictionary.latest, lambda ip=ip : docol(ip), False) 1134 | dictionary.words[dictionary.latest] = compiling_word 1135 | dictionary.words[dictionary.latest].body = ip 1136 | stack.append(compiling_word.xt) 1137 | compiling_word.ip = ip 1138 | raw_data_word = None 1139 | set_state(True) 1140 | 1141 | def U_GT(): 1142 | lhs = ctypes.c_ushort(stack[-2]) 1143 | rhs = ctypes.c_ushort(stack[-1]) 1144 | stack[-2] = -1 if lhs.value > rhs.value else 0 1145 | stack.pop() 1146 | 1147 | def UNUSED(): 1148 | stack.append(ctypes.c_short(len(heap) - here).value) 1149 | 1150 | def MARKER(): 1151 | old_dictionary = dictionary.copy() 1152 | old_here = here 1153 | CREATE() 1154 | def restore(): 1155 | global here 1156 | global dictionary 1157 | here = old_here 1158 | dictionary = old_dictionary 1159 | dictionary.words[dictionary.latest].xt = restore 1160 | 1161 | def COMPILE_COMMA(): 1162 | append(stack.pop()) 1163 | 1164 | def TO(): 1165 | TICK() 1166 | TO_BODY() 1167 | if heap[state_addr]: 1168 | stack.append(LIT) 1169 | COMPILE_COMMA() 1170 | COMMA() 1171 | stack.append(dictionary.words["!"].xt) 1172 | COMPILE_COMMA() 1173 | else: 1174 | STORE() 1175 | 1176 | def _OF(): 1177 | global ip 1178 | OVER() 1179 | EQUALS() 1180 | if stack.pop(): 1181 | DROP() 1182 | ip += 2 1183 | else: 1184 | BRANCH() 1185 | 1186 | def LITERAL(): 1187 | top = stack.getchar() 1188 | if callable(top): 1189 | append(LIT) 1190 | COMMA() 1191 | elif (type(top) == int and top & 0xff00) or type(top) == xc.Ref: 1192 | append(LIT) 1193 | COMMA() 1194 | else: 1195 | append(LITC) 1196 | C_COMMA() 1197 | 1198 | def PARSE(): 1199 | delim = stack.pop() 1200 | stack.append(tib_addr + heap[to_in_addr]) 1201 | stack.append(0) 1202 | while True: 1203 | if heap[to_in_addr] == tib_count: 1204 | return 1205 | if heap[tib_addr + heap[to_in_addr]] == delim: 1206 | heap[to_in_addr] += 1 1207 | return 1208 | heap[to_in_addr] += 1 1209 | ONEPLUS() 1210 | 1211 | def WORDS(): 1212 | l = [] 1213 | for k in dictionary.words.keys(): 1214 | l.append(str(k)) 1215 | l.sort() 1216 | print(" ".join(l)) 1217 | 1218 | def COMPILE(): 1219 | name = parse(' ') 1220 | outfile = name + ".asm" 1221 | print("compile", name, "to", outfile, "...") 1222 | xc.compile(dictionary, heap, name, outfile) 1223 | print("ok") 1224 | 1225 | def CODE(): 1226 | word_name = parse(' ') 1227 | code = "" 1228 | prev_to_in = heap[to_in_addr] 1229 | while True: 1230 | w = parse(' ') 1231 | if w: 1232 | if w.lower() == ";code": 1233 | dictionary.code_words[word_name] = code 1234 | return 1235 | code += "".join(heap[tib_addr + prev_to_in : tib_addr + heap[to_in_addr]]) 1236 | prev_to_in = heap[to_in_addr] 1237 | else: 1238 | code += "\n" 1239 | prev_to_in = 0 1240 | REFILL() 1241 | assert stack.pop() 1242 | 1243 | def D_PLUS(): 1244 | d1 = ctypes.c_ushort(stack[-2]).value 1245 | d1 += ctypes.c_ushort(stack[-1]).value << 16 1246 | d2 = ctypes.c_ushort(stack[-4]).value 1247 | d2 += ctypes.c_ushort(stack[-3]).value << 16 1248 | s = d1 + d2 1249 | stack.pop() 1250 | stack.pop() 1251 | stack[-1] = ctypes.c_short(s >> 16).value 1252 | stack[-2] = ctypes.c_short(s & 0xffff).value 1253 | 1254 | def PAGE(): 1255 | os.system('cls' if os.name == 'nt' else 'clear') 1256 | 1257 | add_word("refill", REFILL) 1258 | add_word("variable", VARIABLE) 1259 | add_word("!", STORE) 1260 | add_word("+!", PLUSSTORE) 1261 | add_word(":", COLON) 1262 | add_word(";", SEMICOLON, True) 1263 | add_word("depth", DEPTH) 1264 | add_word("dup", DUP) 1265 | add_word("2dup", TWODUP) 1266 | add_word("over", OVER) 1267 | add_word("rot", ROT) 1268 | add_word("swap", SWAP) 1269 | add_word("drop", DROP) 1270 | add_word("0<", ZERO_LT) 1271 | add_word("0branch", ZBRANCH) 1272 | add_word("branch", BRANCH) 1273 | add_word("else", ELSE, True) 1274 | add_word("then", THEN, True) 1275 | add_word("cr", CR) 1276 | add_word("j", J) 1277 | add_word("=", EQUALS) 1278 | add_word("0=", ZEQUAL) 1279 | add_word('s"', S_QUOTE, True) 1280 | add_word('s\\"', S_BACKSLASH_QUOTE, True) 1281 | add_word('c"', C_QUOTE, True) 1282 | add_word("do", DO, True) 1283 | add_word("(do)", _DO) 1284 | add_word("loop", LOOP, True) 1285 | add_word("(loop)", _LOOP) 1286 | add_word("+loop", PLUSLOOP, True) 1287 | add_word("(+loop)", _PLUSLOOP) 1288 | add_word("exit", EXIT) 1289 | add_word("type", TYPE) 1290 | add_word("source", SOURCE) 1291 | add_word("@", FETCH) 1292 | add_word("1+", ONEPLUS) 1293 | add_word("1-", ONEMINUS) 1294 | add_word("+", PLUS) 1295 | add_word("-", MINUS) 1296 | add_word("abs", ABS) 1297 | add_word("quit", QUIT) 1298 | add_word("create", CREATE) 1299 | add_word("allot", ALLOT) 1300 | add_word("sliteral", SLITERAL) 1301 | add_word("leave", LEAVE, True) 1302 | add_word("unloop", UNLOOP, True) 1303 | add_word(">r", TO_R) 1304 | add_word("r>", R_TO) 1305 | add_word("r@", R_FETCH) 1306 | add_word(">in", TO_IN) 1307 | add_word("(", LPAREN, True) 1308 | add_word("and", AND) 1309 | add_word("or", OR) 1310 | add_word("xor", XOR) 1311 | add_word("lshift", LSHIFT) 1312 | add_word("rshift", RSHIFT) 1313 | add_word("2*", TWOMUL) 1314 | add_word("2/", TWODIV) 1315 | add_word("invert", INVERT) 1316 | add_word("constant", CONSTANT) 1317 | add_word("<", LESS_THAN) 1318 | add_word(">", GREATER_THAN) 1319 | add_word("u<", U_LESS) 1320 | add_word("*", MULTIPLY) 1321 | add_word("m*", M_MULTIPLY) 1322 | add_word("um*", UM_MULTIPLY) 1323 | add_word("um/mod", UM_MOD) 1324 | add_word("tuck", TUCK) 1325 | add_word("literal", LITERAL, True) 1326 | add_word("postpone", POSTPONE, True) 1327 | add_word("here", HERE) 1328 | add_word(",", COMMA) 1329 | add_word("c,", C_COMMA) 1330 | add_word("c@", C_FETCH) 1331 | add_word("c!", C_STORE) 1332 | add_word("while", WHILE, True) 1333 | add_word("repeat", REPEAT, True) 1334 | add_word("until", UNTIL, True) 1335 | add_word("again", AGAIN, True) 1336 | add_word("char", CHAR) 1337 | add_word("[char]", COMPILE_CHAR, True) 1338 | add_word("'", TICK) 1339 | add_word("execute", EXECUTE) 1340 | add_word("[']", COMPILE_TICK, True) 1341 | add_word("immediate", IMMEDIATE) 1342 | add_word("find", FIND) 1343 | add_word("lit", LIT) 1344 | add_word("litc", LITC) 1345 | add_word("state", STATE) 1346 | add_word("recurse", RECURSE, True) 1347 | add_word("does>", DOES_TO) 1348 | add_word(">body", TO_BODY) 1349 | add_word("evaluate", EVALUATE) 1350 | add_word("word", WORD) 1351 | add_word("fill", FILL) 1352 | add_word("move", MOVE) 1353 | add_word('."', DOT_QUOTE, True) 1354 | add_word("emit", EMIT) 1355 | add_word("dabs", DABS) 1356 | add_word("accept", ACCEPT) 1357 | add_word(".(", DOT_LPAREN, True) 1358 | add_word(":noname", COLON_NONAME) 1359 | add_word("u>", U_GT) 1360 | add_word("pick", PICK) 1361 | add_word("unused", UNUSED) 1362 | add_word("marker", MARKER) 1363 | add_word("?do", QUESTION_DO, True) 1364 | add_word("(?do)", _QUESTION_DO) 1365 | add_word("to", TO, True) 1366 | add_word("(of)", _OF) 1367 | add_word("parse", PARSE) 1368 | add_word("source-id", SOURCE_ID) 1369 | add_word("bye", lambda : sys.exit(0)) 1370 | add_word("words", WORDS) 1371 | add_word("2drop", TWODROP) 1372 | add_word("code", CODE) 1373 | add_word("compile,", COMPILE_COMMA) 1374 | add_word("compile", COMPILE) 1375 | add_word("d+", D_PLUS) 1376 | add_word("page", PAGE) 1377 | add_word("0", lambda : stack.append(0)) 1378 | 1379 | def evaluate_file(filename): 1380 | global INPUT_FILE 1381 | INPUT_FILE = open(filename, mode='r') 1382 | 1383 | while True: 1384 | REFILL() 1385 | if stack.pop() == 0: 1386 | return 1387 | interpret_tib() 1388 | 1389 | __location__ = os.path.realpath(os.path.join(os.getcwd(), os.path.dirname(__file__))) 1390 | evaluate_file(os.path.join(__location__, "src/words.fs")) 1391 | 1392 | if len(sys.argv) > 1: 1393 | args = sys.argv[1:] 1394 | for infile in args: 1395 | evaluate_file(infile) 1396 | else: 1397 | print("ACMEforth v0.0.1 :: Copyright (C) 2019 Johan Kotlinski") 1398 | try: 1399 | QUIT() 1400 | except EOFError: 1401 | pass 1402 | -------------------------------------------------------------------------------- /test/target.fs: -------------------------------------------------------------------------------- 1 | \ ----- testcore.fs 2 | 3 | : BITSSET? IF 0 0 ELSE 0 THEN ; 4 | 5 | : test-basic-assumptions 6 | ." testing basic assumptions" cr 7 | T{ -> }T \ START WITH CLEAN SLATE 8 | ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) 9 | T{ 0 BITSSET? -> 0 }T ( ZERO IS ALL BITS CLEAR ) 10 | T{ 1 BITSSET? -> 0 0 }T ( OTHER NUMBER HAVE AT LEAST ONE BIT ) 11 | T{ -1 BITSSET? -> 0 0 }T ; 12 | 13 | 0 CONSTANT 0S 14 | 0 INVERT CONSTANT 1S 15 | 16 | \ ----- 17 | 18 | : test-booleans 19 | ." testing booleans invert and or xor" cr 20 | T{ 0 0 AND -> 0 }T 21 | T{ 0 1 AND -> 0 }T 22 | T{ 1 0 AND -> 0 }T 23 | T{ 1 1 AND -> 1 }T 24 | 25 | T{ 0 INVERT 1 AND -> 1 }T 26 | T{ 1 INVERT 1 AND -> 0 }T 27 | 28 | T{ 0S INVERT -> 1S }T 29 | T{ 1S INVERT -> 0S }T 30 | 31 | T{ 0S 0S AND -> 0S }T 32 | T{ 0S 1S AND -> 0S }T 33 | T{ 1S 0S AND -> 0S }T 34 | T{ 1S 1S AND -> 1S }T 35 | 36 | T{ 0S 0S OR -> 0S }T 37 | T{ 0S 1S OR -> 1S }T 38 | T{ 1S 0S OR -> 1S }T 39 | T{ 1S 1S OR -> 1S }T 40 | 41 | T{ 0S 0S XOR -> 0S }T 42 | T{ 0S 1S XOR -> 1S }T 43 | T{ 1S 0S XOR -> 1S }T 44 | T{ 1S 1S XOR -> 0S }T ; 45 | 46 | \ ----- 47 | 48 | 1S 1 RSHIFT INVERT CONSTANT MSB 49 | : test-shift 50 | ." testing 2* 2/ lshift rshift" cr 51 | 52 | ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) 53 | T{ MSB BITSSET? -> 0 0 }T 54 | 55 | T{ 0S 2* -> 0S }T 56 | T{ 1 2* -> 2 }T 57 | T{ 4000 2* -> 8000 }T 58 | T{ 1S 2* 1 XOR -> 1S }T 59 | T{ MSB 2* -> 0S }T 60 | 61 | T{ 0S 2/ -> 0S }T 62 | T{ 1 2/ -> 0 }T 63 | T{ 4000 2/ -> 2000 }T 64 | T{ 1S 2/ -> 1S }T \ MSB PROPOGATED 65 | T{ 1S 1 XOR 2/ -> 1S }T 66 | T{ MSB 2/ MSB AND -> MSB }T 67 | 68 | T{ 1 0 LSHIFT -> 1 }T 69 | T{ 1 1 LSHIFT -> 2 }T 70 | T{ 1 2 LSHIFT -> 4 }T 71 | T{ 1 F LSHIFT -> 8000 }T \ BIGGEST GUARANTEED SHIFT 72 | T{ 1S 1 LSHIFT 1 XOR -> 1S }T 73 | T{ MSB 1 LSHIFT -> 0 }T 74 | 75 | T{ 1 0 RSHIFT -> 1 }T 76 | T{ 1 1 RSHIFT -> 0 }T 77 | T{ 2 1 RSHIFT -> 1 }T 78 | T{ 4 2 RSHIFT -> 1 }T 79 | T{ 8000 F RSHIFT -> 1 }T \ BIGGEST 80 | T{ MSB 1 RSHIFT MSB AND -> 0 }T \ RSHIFT ZERO FILLS MSBS 81 | T{ MSB 1 RSHIFT 2* -> MSB }T ; 82 | 83 | \ ----- 84 | 85 | 0 INVERT CONSTANT MAX-UINT 86 | 0 INVERT 1 RSHIFT CONSTANT MAX-INT 87 | 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT 88 | 0 INVERT 1 RSHIFT CONSTANT MID-UINT 89 | 0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 90 | 91 | 0S CONSTANT 92 | 1S CONSTANT 93 | 94 | : test-comparisons 95 | ." testing comparisons: 0= = 0< < > u< min max" cr 96 | 97 | T{ 0 0= -> }T 98 | T{ 1 0= -> }T 99 | T{ 2 0= -> }T 100 | T{ -1 0= -> }T 101 | T{ MAX-UINT 0= -> }T 102 | T{ MIN-INT 0= -> }T 103 | T{ MAX-INT 0= -> }T 104 | 105 | T{ 0 0 = -> }T 106 | T{ 1 1 = -> }T 107 | T{ -1 -1 = -> }T 108 | T{ 1 0 = -> }T 109 | T{ -1 0 = -> }T 110 | T{ 0 1 = -> }T 111 | T{ 0 -1 = -> }T 112 | 113 | T{ 0 0< -> }T 114 | T{ -1 0< -> }T 115 | T{ MIN-INT 0< -> }T 116 | T{ 1 0< -> }T 117 | T{ MAX-INT 0< -> }T 118 | 119 | T{ 0 1 < -> }T 120 | T{ 1 2 < -> }T 121 | T{ -1 0 < -> }T 122 | T{ -1 1 < -> }T 123 | T{ MIN-INT 0 < -> }T 124 | T{ MIN-INT MAX-INT < -> }T 125 | T{ 0 MAX-INT < -> }T 126 | T{ 0 0 < -> }T 127 | T{ 1 1 < -> }T 128 | T{ 1 0 < -> }T 129 | T{ 2 1 < -> }T 130 | T{ 0 -1 < -> }T 131 | T{ 1 -1 < -> }T 132 | T{ 0 MIN-INT < -> }T 133 | T{ MAX-INT MIN-INT < -> }T 134 | T{ MAX-INT 0 < -> }T 135 | 136 | T{ 0 1 > -> }T 137 | T{ 1 2 > -> }T 138 | T{ -1 0 > -> }T 139 | T{ -1 1 > -> }T 140 | T{ MIN-INT 0 > -> }T 141 | T{ MIN-INT MAX-INT > -> }T 142 | T{ 0 MAX-INT > -> }T 143 | T{ 0 0 > -> }T 144 | T{ 1 1 > -> }T 145 | T{ 1 0 > -> }T 146 | T{ 2 1 > -> }T 147 | T{ 0 -1 > -> }T 148 | T{ 1 -1 > -> }T 149 | T{ 0 MIN-INT > -> }T 150 | T{ MAX-INT MIN-INT > -> }T 151 | T{ MAX-INT 0 > -> }T 152 | 153 | T{ 0 1 U< -> }T 154 | T{ 1 2 U< -> }T 155 | T{ 0 MID-UINT U< -> }T 156 | T{ 0 MAX-UINT U< -> }T 157 | T{ MID-UINT MAX-UINT U< -> }T 158 | T{ 0 0 U< -> }T 159 | T{ 1 1 U< -> }T 160 | T{ 1 0 U< -> }T 161 | T{ 2 1 U< -> }T 162 | T{ MID-UINT 0 U< -> }T 163 | T{ MAX-UINT 0 U< -> }T 164 | T{ MAX-UINT MID-UINT U< -> }T 165 | 166 | T{ 0 1 MIN -> 0 }T 167 | T{ 1 2 MIN -> 1 }T 168 | T{ -1 0 MIN -> -1 }T 169 | T{ -1 1 MIN -> -1 }T 170 | T{ MIN-INT 0 MIN -> MIN-INT }T 171 | T{ MIN-INT MAX-INT MIN -> MIN-INT }T 172 | T{ 0 MAX-INT MIN -> 0 }T 173 | T{ 0 0 MIN -> 0 }T 174 | T{ 1 1 MIN -> 1 }T 175 | T{ 1 0 MIN -> 0 }T 176 | T{ 2 1 MIN -> 1 }T 177 | T{ 0 -1 MIN -> -1 }T 178 | T{ 1 -1 MIN -> -1 }T 179 | T{ 0 MIN-INT MIN -> MIN-INT }T 180 | T{ MAX-INT MIN-INT MIN -> MIN-INT }T 181 | T{ MAX-INT 0 MIN -> 0 }T 182 | 183 | T{ 0 1 MAX -> 1 }T 184 | T{ 1 2 MAX -> 2 }T 185 | T{ -1 0 MAX -> 0 }T 186 | T{ -1 1 MAX -> 1 }T 187 | T{ MIN-INT 0 MAX -> 0 }T 188 | T{ MIN-INT MAX-INT MAX -> MAX-INT }T 189 | T{ 0 MAX-INT MAX -> MAX-INT }T 190 | T{ 0 0 MAX -> 0 }T 191 | T{ 1 1 MAX -> 1 }T 192 | T{ 1 0 MAX -> 1 }T 193 | T{ 2 1 MAX -> 2 }T 194 | T{ 0 -1 MAX -> 0 }T 195 | T{ 1 -1 MAX -> 1 }T 196 | T{ 0 MIN-INT MAX -> 0 }T 197 | T{ MAX-INT MIN-INT MAX -> MAX-INT }T 198 | T{ MAX-INT 0 MAX -> MAX-INT }T ; 199 | 200 | \ ----- 201 | 202 | : test-stack-ops 203 | ." testing stack ops: 2drop 2dup 2over 2swap ?dup depth drop dup over rot swap" cr 204 | T{ 1 2 2DROP -> }T 205 | T{ 1 2 2DUP -> 1 2 1 2 }T 206 | T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T 207 | T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T 208 | T{ 0 ?DUP -> 0 }T 209 | T{ 1 ?DUP -> 1 1 }T 210 | T{ -1 ?DUP -> -1 -1 }T 211 | T{ DEPTH -> 0 }T 212 | T{ 0 DEPTH -> 0 1 }T 213 | T{ 0 1 DEPTH -> 0 1 2 }T 214 | T{ 0 DROP -> }T 215 | T{ 1 2 DROP -> 1 }T 216 | T{ 1 DUP -> 1 1 }T 217 | T{ 1 2 OVER -> 1 2 1 }T 218 | T{ 1 2 3 ROT -> 2 3 1 }T 219 | T{ 1 2 SWAP -> 2 1 }T ; 220 | 221 | \ ----- 222 | 223 | : GR1 >R R> ; 224 | : GR2 >R R@ R> DROP ; 225 | : test-return-stack-ops 226 | ." testing >r r> r@" cr 227 | T{ 123 GR1 -> 123 }T 228 | T{ 123 GR2 -> 123 }T 229 | T{ 1S GR1 -> 1S }T ; ( RETURN STACK HOLDS CELLS ) 230 | 231 | \ ----- 232 | 233 | : test-add-subtract 234 | ." testing add/subtract: + - 1+ 1- abs negate" cr 235 | T{ 0 5 + -> 5 }T 236 | T{ 5 0 + -> 5 }T 237 | T{ 0 -5 + -> -5 }T 238 | T{ -5 0 + -> -5 }T 239 | T{ 1 2 + -> 3 }T 240 | T{ 1 -2 + -> -1 }T 241 | T{ -1 2 + -> 1 }T 242 | T{ -1 -2 + -> -3 }T 243 | T{ -1 1 + -> 0 }T 244 | T{ MID-UINT 1 + -> MID-UINT+1 }T 245 | 246 | T{ 0 5 - -> -5 }T 247 | T{ 5 0 - -> 5 }T 248 | T{ 0 -5 - -> 5 }T 249 | T{ -5 0 - -> -5 }T 250 | T{ 1 2 - -> -1 }T 251 | T{ 1 -2 - -> 3 }T 252 | T{ -1 2 - -> -3 }T 253 | T{ -1 -2 - -> 1 }T 254 | T{ 0 1 - -> -1 }T 255 | T{ MID-UINT+1 1 - -> MID-UINT }T 256 | 257 | T{ 0 1+ -> 1 }T 258 | T{ -1 1+ -> 0 }T 259 | T{ 1 1+ -> 2 }T 260 | T{ MID-UINT 1+ -> MID-UINT+1 }T 261 | 262 | T{ 2 1- -> 1 }T 263 | T{ 1 1- -> 0 }T 264 | T{ 0 1- -> -1 }T 265 | T{ MID-UINT+1 1- -> MID-UINT }T 266 | 267 | T{ 0 NEGATE -> 0 }T 268 | T{ 1 NEGATE -> -1 }T 269 | T{ -1 NEGATE -> 1 }T 270 | T{ 2 NEGATE -> -2 }T 271 | T{ -2 NEGATE -> 2 }T 272 | 273 | T{ 0 ABS -> 0 }T 274 | T{ 1 ABS -> 1 }T 275 | T{ -1 ABS -> 1 }T 276 | T{ MIN-INT ABS -> MID-UINT+1 }T ; 277 | 278 | \ ----- 279 | 280 | : test-multiply 281 | ." testing multiply: s>d * m* um*" cr 282 | 283 | T{ 0 S>D -> 0 0 }T 284 | T{ 1 S>D -> 1 0 }T 285 | T{ 2 S>D -> 2 0 }T 286 | T{ -1 S>D -> -1 -1 }T 287 | T{ -2 S>D -> -2 -1 }T 288 | T{ MIN-INT S>D -> MIN-INT -1 }T 289 | T{ MAX-INT S>D -> MAX-INT 0 }T 290 | 291 | T{ 0 0 M* -> 0 S>D }T 292 | T{ 0 1 M* -> 0 S>D }T 293 | T{ 1 0 M* -> 0 S>D }T 294 | T{ 1 2 M* -> 2 S>D }T 295 | T{ 2 1 M* -> 2 S>D }T 296 | T{ 3 3 M* -> 9 S>D }T 297 | T{ -3 3 M* -> -9 S>D }T 298 | T{ 3 -3 M* -> -9 S>D }T 299 | T{ -3 -3 M* -> 9 S>D }T 300 | T{ 0 MIN-INT M* -> 0 S>D }T 301 | T{ 1 MIN-INT M* -> MIN-INT S>D }T 302 | T{ 2 MIN-INT M* -> 0 1S }T 303 | T{ 0 MAX-INT M* -> 0 S>D }T 304 | T{ 1 MAX-INT M* -> MAX-INT S>D }T 305 | T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T 306 | T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T 307 | T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T 308 | T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T 309 | 310 | T{ 0 0 * -> 0 }T \ TEST IDENTITIES 311 | T{ 0 1 * -> 0 }T 312 | T{ 1 0 * -> 0 }T 313 | T{ 1 2 * -> 2 }T 314 | T{ 2 1 * -> 2 }T 315 | T{ 3 3 * -> 9 }T 316 | T{ -3 3 * -> -9 }T 317 | T{ 3 -3 * -> -9 }T 318 | T{ -3 -3 * -> 9 }T 319 | 320 | T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T 321 | T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T 322 | T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T 323 | 324 | T{ 0 0 UM* -> 0 0 }T 325 | T{ 0 1 UM* -> 0 0 }T 326 | T{ 1 0 UM* -> 0 0 }T 327 | T{ 1 2 UM* -> 2 0 }T 328 | T{ 2 1 UM* -> 2 0 }T 329 | T{ 3 3 UM* -> 9 0 }T 330 | 331 | T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T 332 | T{ MID-UINT+1 2 UM* -> 0 1 }T 333 | T{ MID-UINT+1 4 UM* -> 0 2 }T 334 | T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T 335 | T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T ; 336 | 337 | \ ----- 338 | 339 | : IFFLOORED 340 | [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ; 341 | 342 | : IFSYM 343 | [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ; 344 | 345 | IFFLOORED : T/MOD >R S>D R> FM/MOD ; 346 | IFFLOORED : T/ T/MOD SWAP DROP ; 347 | IFFLOORED : TMOD T/MOD DROP ; 348 | IFFLOORED : T*/MOD >R M* R> FM/MOD ; 349 | IFFLOORED : T*/ T*/MOD SWAP DROP ; 350 | IFSYM : T/MOD >R S>D R> SM/REM ; 351 | IFSYM : T/ T/MOD SWAP DROP ; 352 | IFSYM : TMOD T/MOD DROP ; 353 | IFSYM : T*/MOD >R M* R> SM/REM ; 354 | IFSYM : T*/ T*/MOD SWAP DROP ; 355 | 356 | : test-divide 357 | ." testing divide: fm/mod sm/rem um/mod */ */mod / /mod mod" cr 358 | 359 | T{ 0 S>D 1 FM/MOD -> 0 0 }T 360 | T{ 1 S>D 1 FM/MOD -> 0 1 }T 361 | T{ 2 S>D 1 FM/MOD -> 0 2 }T 362 | T{ -1 S>D 1 FM/MOD -> 0 -1 }T 363 | T{ -2 S>D 1 FM/MOD -> 0 -2 }T 364 | T{ 0 S>D -1 FM/MOD -> 0 0 }T 365 | T{ 1 S>D -1 FM/MOD -> 0 -1 }T 366 | T{ 2 S>D -1 FM/MOD -> 0 -2 }T 367 | T{ -1 S>D -1 FM/MOD -> 0 1 }T 368 | T{ -2 S>D -1 FM/MOD -> 0 2 }T 369 | T{ 2 S>D 2 FM/MOD -> 0 1 }T 370 | T{ -1 S>D -1 FM/MOD -> 0 1 }T 371 | T{ -2 S>D -2 FM/MOD -> 0 1 }T 372 | T{ 7 S>D 3 FM/MOD -> 1 2 }T 373 | T{ 7 S>D -3 FM/MOD -> -2 -3 }T 374 | T{ -7 S>D 3 FM/MOD -> 2 -3 }T 375 | T{ -7 S>D -3 FM/MOD -> -1 2 }T 376 | T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T 377 | T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T 378 | T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T 379 | T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T 380 | T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T 381 | T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T 382 | T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T 383 | T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T 384 | T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T 385 | T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T 386 | T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T 387 | T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T 388 | T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T 389 | T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T 390 | T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T 391 | T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T 392 | T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T 393 | 394 | T{ 0 S>D 1 SM/REM -> 0 0 }T 395 | T{ 1 S>D 1 SM/REM -> 0 1 }T 396 | T{ 2 S>D 1 SM/REM -> 0 2 }T 397 | T{ -1 S>D 1 SM/REM -> 0 -1 }T 398 | T{ -2 S>D 1 SM/REM -> 0 -2 }T 399 | T{ 0 S>D -1 SM/REM -> 0 0 }T 400 | T{ 1 S>D -1 SM/REM -> 0 -1 }T 401 | T{ 2 S>D -1 SM/REM -> 0 -2 }T 402 | T{ -1 S>D -1 SM/REM -> 0 1 }T 403 | T{ -2 S>D -1 SM/REM -> 0 2 }T 404 | T{ 2 S>D 2 SM/REM -> 0 1 }T 405 | T{ -1 S>D -1 SM/REM -> 0 1 }T 406 | T{ -2 S>D -2 SM/REM -> 0 1 }T 407 | T{ 7 S>D 3 SM/REM -> 1 2 }T 408 | T{ 7 S>D -3 SM/REM -> 1 -2 }T 409 | T{ -7 S>D 3 SM/REM -> -1 -2 }T 410 | T{ -7 S>D -3 SM/REM -> -1 2 }T 411 | T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T 412 | T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T 413 | T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T 414 | T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T 415 | T{ 1S 1 4 SM/REM -> 3 MAX-INT }T 416 | T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T 417 | T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T 418 | T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T 419 | T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T 420 | T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T 421 | T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T 422 | T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T 423 | T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T 424 | 425 | T{ 0 0 1 UM/MOD -> 0 0 }T 426 | T{ 1 0 1 UM/MOD -> 0 1 }T 427 | T{ 1 0 2 UM/MOD -> 1 0 }T 428 | T{ 3 0 2 UM/MOD -> 1 1 }T 429 | T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T 430 | T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T 431 | T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T 432 | 433 | \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION. 434 | \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST. 435 | 436 | T{ 0 1 /MOD -> 0 1 T/MOD }T 437 | T{ 1 1 /MOD -> 1 1 T/MOD }T 438 | T{ 2 1 /MOD -> 2 1 T/MOD }T 439 | T{ -1 1 /MOD -> -1 1 T/MOD }T 440 | T{ -2 1 /MOD -> -2 1 T/MOD }T 441 | T{ 0 -1 /MOD -> 0 -1 T/MOD }T 442 | T{ 1 -1 /MOD -> 1 -1 T/MOD }T 443 | T{ 2 -1 /MOD -> 2 -1 T/MOD }T 444 | T{ -1 -1 /MOD -> -1 -1 T/MOD }T 445 | T{ -2 -1 /MOD -> -2 -1 T/MOD }T 446 | T{ 2 2 /MOD -> 2 2 T/MOD }T 447 | T{ -1 -1 /MOD -> -1 -1 T/MOD }T 448 | T{ -2 -2 /MOD -> -2 -2 T/MOD }T 449 | T{ 7 3 /MOD -> 7 3 T/MOD }T 450 | T{ 7 -3 /MOD -> 7 -3 T/MOD }T 451 | T{ -7 3 /MOD -> -7 3 T/MOD }T 452 | T{ -7 -3 /MOD -> -7 -3 T/MOD }T 453 | T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T 454 | T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T 455 | T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T 456 | T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T 457 | 458 | T{ 0 1 / -> 0 1 T/ }T 459 | T{ 1 1 / -> 1 1 T/ }T 460 | T{ 2 1 / -> 2 1 T/ }T 461 | T{ -1 1 / -> -1 1 T/ }T 462 | T{ -2 1 / -> -2 1 T/ }T 463 | T{ 0 -1 / -> 0 -1 T/ }T 464 | T{ 1 -1 / -> 1 -1 T/ }T 465 | T{ 2 -1 / -> 2 -1 T/ }T 466 | T{ -1 -1 / -> -1 -1 T/ }T 467 | T{ -2 -1 / -> -2 -1 T/ }T 468 | T{ 2 2 / -> 2 2 T/ }T 469 | T{ -1 -1 / -> -1 -1 T/ }T 470 | T{ -2 -2 / -> -2 -2 T/ }T 471 | T{ 7 3 / -> 7 3 T/ }T 472 | T{ 7 -3 / -> 7 -3 T/ }T 473 | T{ -7 3 / -> -7 3 T/ }T 474 | T{ -7 -3 / -> -7 -3 T/ }T 475 | T{ MAX-INT 1 / -> MAX-INT 1 T/ }T 476 | T{ MIN-INT 1 / -> MIN-INT 1 T/ }T 477 | T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T 478 | T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T 479 | 480 | T{ 0 1 MOD -> 0 1 TMOD }T 481 | T{ 1 1 MOD -> 1 1 TMOD }T 482 | T{ 2 1 MOD -> 2 1 TMOD }T 483 | T{ -1 1 MOD -> -1 1 TMOD }T 484 | T{ -2 1 MOD -> -2 1 TMOD }T 485 | T{ 0 -1 MOD -> 0 -1 TMOD }T 486 | T{ 1 -1 MOD -> 1 -1 TMOD }T 487 | T{ 2 -1 MOD -> 2 -1 TMOD }T 488 | T{ -1 -1 MOD -> -1 -1 TMOD }T 489 | T{ -2 -1 MOD -> -2 -1 TMOD }T 490 | T{ 2 2 MOD -> 2 2 TMOD }T 491 | T{ -1 -1 MOD -> -1 -1 TMOD }T 492 | T{ -2 -2 MOD -> -2 -2 TMOD }T 493 | T{ 7 3 MOD -> 7 3 TMOD }T 494 | T{ 7 -3 MOD -> 7 -3 TMOD }T 495 | T{ -7 3 MOD -> -7 3 TMOD }T 496 | T{ -7 -3 MOD -> -7 -3 TMOD }T 497 | T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T 498 | T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T 499 | T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T 500 | T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T 501 | 502 | T{ 0 2 1 */ -> 0 2 1 T*/ }T 503 | T{ 1 2 1 */ -> 1 2 1 T*/ }T 504 | T{ 2 2 1 */ -> 2 2 1 T*/ }T 505 | T{ -1 2 1 */ -> -1 2 1 T*/ }T 506 | T{ -2 2 1 */ -> -2 2 1 T*/ }T 507 | T{ 0 2 -1 */ -> 0 2 -1 T*/ }T 508 | T{ 1 2 -1 */ -> 1 2 -1 T*/ }T 509 | T{ 2 2 -1 */ -> 2 2 -1 T*/ }T 510 | T{ -1 2 -1 */ -> -1 2 -1 T*/ }T 511 | T{ -2 2 -1 */ -> -2 2 -1 T*/ }T 512 | T{ 2 2 2 */ -> 2 2 2 T*/ }T 513 | T{ -1 2 -1 */ -> -1 2 -1 T*/ }T 514 | T{ -2 2 -2 */ -> -2 2 -2 T*/ }T 515 | T{ 7 2 3 */ -> 7 2 3 T*/ }T 516 | T{ 7 2 -3 */ -> 7 2 -3 T*/ }T 517 | T{ -7 2 3 */ -> -7 2 3 T*/ }T 518 | T{ -7 2 -3 */ -> -7 2 -3 T*/ }T 519 | T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T 520 | T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T 521 | 522 | T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T 523 | T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T 524 | T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T 525 | T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T 526 | T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T 527 | T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T 528 | T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T 529 | T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T 530 | T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T 531 | T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T 532 | T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T 533 | T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T 534 | T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T 535 | T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T 536 | T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T 537 | T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T 538 | T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T 539 | T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T 540 | T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T ; 541 | 542 | \ ----- 543 | 544 | HERE 1 ALLOT 545 | HERE 546 | CONSTANT 2NDA 547 | CONSTANT 1STA 548 | 549 | HERE 1 , 550 | HERE 2 , 551 | CONSTANT 2ND 552 | CONSTANT 1ST 553 | 554 | HERE 1 C, 555 | HERE 2 C, 556 | CONSTANT 2NDC 557 | CONSTANT 1STC 558 | 559 | ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT 560 | CONSTANT A-ADDR CONSTANT UA-ADDR 561 | 562 | : BITS ( X -- U ) 563 | 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ; 564 | 565 | : test-here 566 | ." testing here , @ ! cell+ cells c, c@ c! chars 2@ 2! align aligned +! allot" cr 567 | 568 | T{ 1STA 2NDA U< -> }T \ HERE MUST GROW WITH ALLOT 569 | T{ 1STA 1+ -> 2NDA }T \ ... BY ONE ADDRESS UNIT 570 | ( MISSING TEST: NEGATIVE ALLOT ) 571 | 572 | T{ 1ST 2ND U< -> }T \ HERE MUST GROW WITH ALLOT 573 | T{ 1ST CELL+ -> 2ND }T \ ... BY ONE CELL 574 | T{ 1ST 1 CELLS + -> 2ND }T 575 | T{ 1ST @ 2ND @ -> 1 2 }T 576 | T{ 5 1ST ! -> }T 577 | T{ 1ST @ 2ND @ -> 5 2 }T 578 | T{ 6 2ND ! -> }T 579 | T{ 1ST @ 2ND @ -> 5 6 }T 580 | T{ 1ST 2@ -> 6 5 }T 581 | T{ 2 1 1ST 2! -> }T 582 | T{ 1ST 2@ -> 2 1 }T 583 | T{ 1S 1ST ! 1ST @ -> 1S }T \ CAN STORE CELL-WIDE VALUE 584 | 585 | T{ 1STC 2NDC U< -> }T \ HERE MUST GROW WITH ALLOT 586 | T{ 1STC CHAR+ -> 2NDC }T \ ... BY ONE CHAR 587 | T{ 1STC 1 CHARS + -> 2NDC }T 588 | T{ 1STC C@ 2NDC C@ -> 1 2 }T 589 | T{ 3 1STC C! -> }T 590 | T{ 1STC C@ 2NDC C@ -> 3 2 }T 591 | T{ 4 2NDC C! -> }T 592 | T{ 1STC C@ 2NDC C@ -> 3 4 }T 593 | 594 | T{ UA-ADDR ALIGNED -> A-ADDR }T 595 | T{ 1 A-ADDR C! A-ADDR C@ -> 1 }T 596 | T{ 1234 A-ADDR ! A-ADDR @ -> 1234 }T 597 | T{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 }T 598 | T{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 }T 599 | T{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 }T 600 | T{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 }T 601 | T{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 }T 602 | 603 | ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS ) 604 | T{ 1 CHARS 1 < -> }T 605 | T{ 1 CHARS 1 CELLS > -> }T 606 | ( TBD: HOW TO FIND NUMBER OF BITS? ) 607 | 608 | ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) 609 | T{ 1 CELLS 1 < -> }T 610 | T{ 1 CELLS 1 CHARS MOD -> 0 }T 611 | T{ 1S BITS 10 < -> }T 612 | 613 | T{ 0 1ST ! -> }T 614 | T{ 1 1ST +! -> }T 615 | T{ 1ST @ -> 1 }T 616 | T{ -1 1ST +! 1ST @ -> 0 }T ; 617 | 618 | \ ----- 619 | 620 | : GC1 [CHAR] X ; 621 | : GC2 [CHAR] HELLO ; 622 | : GC3 [ GC1 ] LITERAL ; 623 | : GC4 S" XY" ; 624 | 625 | : test-char 626 | ." testing char [char] [ ] bl s" cr 627 | 628 | T{ BL -> 20 }T 629 | T{ [ CHAR X ] LITERAL -> #216 }T \ petscii 630 | T{ [ CHAR HELLO ] LITERAL -> #200 }T \ petscii 631 | T{ GC1 -> #216 }T \ petscii 632 | T{ GC2 -> #200 }T \ petscii 633 | T{ GC3 -> #216 }T \ petscii 634 | T{ GC4 SWAP DROP -> 2 }T 635 | T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> #216 #217 }T ; \ petscii 636 | 637 | \ ----- 638 | 639 | : GT1 123 ; 640 | : GT2 ['] GT1 ; IMMEDIATE 641 | create gt1string 3 C, CHAR G C, CHAR T C, CHAR 1 C, 642 | : GT3 GT2 LITERAL ; 643 | : GT4 POSTPONE GT1 ; IMMEDIATE 644 | : GT5 GT4 ; 645 | : GT6 345 ; IMMEDIATE 646 | : GT7 POSTPONE GT6 ; 647 | 648 | : test-tick 649 | ." testing ' ['] find execute immediate count literal postpone state" cr 650 | 651 | T{ ['] gt1 execute -> 123 }T 652 | T{ postpone GT2 EXECUTE -> 123 }T 653 | ( HOW TO SEARCH FOR NON-EXISTENT WORD? ) 654 | T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T 655 | 656 | T{ GT5 -> 123 }T 657 | T{ GT7 -> 345 }T ; 658 | 659 | \ ----- 660 | 661 | T{ : GI1 IF 123 THEN ; -> }T 662 | T{ : GI2 IF 123 ELSE 234 THEN ; -> }T 663 | T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T 664 | T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T 665 | T{ : GI5 BEGIN DUP 2 > 666 | WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T 667 | T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T 668 | : test-control 669 | ." testing if else then begin while repeat until recurse" cr 670 | 671 | T{ 0 GI1 -> }T 672 | T{ 1 GI1 -> 123 }T 673 | T{ -1 GI1 -> 123 }T 674 | T{ 0 GI2 -> 234 }T 675 | T{ 1 GI2 -> 123 }T 676 | T{ -1 GI1 -> 123 }T 677 | 678 | T{ 0 GI3 -> 0 1 2 3 4 5 }T 679 | T{ 4 GI3 -> 4 5 }T 680 | T{ 5 GI3 -> 5 }T 681 | T{ 6 GI3 -> 6 }T 682 | 683 | T{ 3 GI4 -> 3 4 5 6 }T 684 | T{ 5 GI4 -> 5 6 }T 685 | T{ 6 GI4 -> 6 7 }T 686 | 687 | T{ 1 GI5 -> 1 345 }T 688 | T{ 2 GI5 -> 2 345 }T 689 | T{ 3 GI5 -> 3 4 5 123 }T 690 | T{ 4 GI5 -> 4 5 123 }T 691 | T{ 5 GI5 -> 5 123 }T 692 | 693 | T{ 0 GI6 -> 0 }T 694 | T{ 1 GI6 -> 0 1 }T 695 | T{ 2 GI6 -> 0 1 2 }T 696 | T{ 3 GI6 -> 0 1 2 3 }T 697 | T{ 4 GI6 -> 0 1 2 3 4 }T ; 698 | 699 | \ ----- 700 | 701 | T{ : GD1 DO I LOOP ; -> }T 702 | T{ : GD2 DO I -1 +LOOP ; -> }T 703 | T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T 704 | T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T 705 | T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T 706 | T{ : GD6 ( PAT: T{0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} ) 707 | 0 SWAP 0 DO 708 | I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP 709 | LOOP ; -> }T 710 | : test-loop 711 | ." testing do loop +loop i j unloop leave exit" cr 712 | 713 | T{ 4 1 GD1 -> 1 2 3 }T 714 | T{ 2 -1 GD1 -> -1 0 1 }T 715 | T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T 716 | 717 | T{ 1 4 GD2 -> 4 3 2 1 }T 718 | T{ -1 2 GD2 -> 2 1 0 -1 }T 719 | T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T 720 | 721 | T{ 4 1 GD3 -> 1 2 3 }T 722 | T{ 2 -1 GD3 -> -1 0 1 }T 723 | T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T 724 | 725 | T{ 1 4 GD4 -> 4 3 2 1 }T 726 | T{ -1 2 GD4 -> 2 1 0 -1 }T 727 | T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T 728 | 729 | T{ 1 GD5 -> 123 }T 730 | T{ 5 GD5 -> 123 }T 731 | T{ 6 GD5 -> 234 }T 732 | 733 | T{ 1 GD6 -> 1 }T 734 | T{ 2 GD6 -> 3 }T 735 | T{ 3 GD6 -> 4 1 2 }T ; 736 | 737 | T{ 123 CONSTANT X123 -> }T 738 | T{ : EQU CONSTANT ; -> }T 739 | T{ X123 EQU Y123 -> }T 740 | T{ VARIABLE V1 -> }T 741 | T{ : NOP : POSTPONE ; ; -> }T 742 | T{ NOP NOP1 NOP NOP2 -> }T 743 | T{ : DOES1 DOES> @ 1 + ; -> }T 744 | T{ : DOES2 DOES> @ 2 + ; -> }T 745 | T{ CREATE CR1 -> }T 746 | T{ CR1 -> HERE }T 747 | T{ ' CR1 >BODY -> HERE }T 748 | T{ 1 , -> }T 749 | T{ CR1 @ -> 1 }T 750 | T{ DOES1 -> }T 751 | T{ CR1 -> 2 }T 752 | T{ DOES2 -> }T 753 | T{ CR1 -> 3 }T ; 754 | T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T 755 | T{ WEIRD: W1 -> }T 756 | T{ ' W1 >BODY -> HERE }T 757 | T{ W1 -> HERE 1 + }T 758 | T{ W1 -> HERE 2 + }T 759 | 760 | : test-defines 761 | ." testing defining words: : ; constant variable create does> >body" cr 762 | 763 | T{ X123 -> 123 }T 764 | T{ Y123 -> 123 }T 765 | 766 | T{ 123 V1 ! -> }T 767 | T{ V1 @ -> 123 }T 768 | 769 | T{ NOP1 -> }T 770 | T{ NOP2 -> }T 771 | 772 | T{ CR1 -> 3 }T ; 773 | 774 | \ ----- <# # #s #> hold sign base >number hex decimal 775 | 776 | : S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. 777 | >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH 778 | R> ?DUP IF \ IF NON-EMPTY STRINGS 779 | 0 DO 780 | OVER C@ OVER C@ - IF 2DROP UNLOOP EXIT THEN 781 | SWAP CHAR+ SWAP CHAR+ 782 | LOOP 783 | THEN 784 | 2DROP \ IF WE GET HERE, STRINGS MATCH 785 | ELSE 786 | R> DROP 2DROP \ LENGTHS MISMATCH 787 | THEN ; 788 | 789 | : GP1 <# 41 HOLD 42 HOLD 0 0 #> S" ba" S= ; \ Changed from BA to ba due to PETSCII. 790 | : GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; 791 | : GP3 <# 1 0 # # #> S" 01" S= ; 792 | : GP4 <# 1 0 #S #> S" 1" S= ; 793 | 24 CONSTANT MAX-BASE \ BASE 2 .. 36 794 | : COUNT-BITS 795 | 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; 796 | COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD 797 | : GP5 798 | BASE @ 799 | MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE 800 | I BASE ! \ TBD: ASSUMES BASE WORKS 801 | I 0 <# #S #> S" 10" S= AND 802 | LOOP 803 | SWAP BASE ! ; 804 | : GP6 805 | BASE @ >R 2 BASE ! 806 | MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY 807 | R> BASE ! \ S: C-ADDR U 808 | DUP #BITS-UD = SWAP 809 | 0 DO \ S: C-ADDR FLAG 810 | OVER C@ [CHAR] 1 = AND \ ALL ONES 811 | >R CHAR+ R> 812 | LOOP SWAP DROP ; 813 | : GP7 814 | BASE @ >R MAX-BASE BASE ! 815 | 816 | A 0 DO 817 | I 0 <# #S #> 818 | 1 = SWAP C@ I 30 + = AND AND 819 | LOOP 820 | MAX-BASE A DO 821 | I 0 <# #S #> 822 | 1 = SWAP C@ 41 I A - + = AND AND 823 | LOOP 824 | R> BASE ! ; 825 | CREATE GN-BUF 0 C, 826 | : GN-STRING GN-BUF 1 ; 827 | : GN-CONSUMED GN-BUF CHAR+ 0 ; 828 | : GN' GN-BUF C! GN-STRING ; 829 | : >NUMBER-BASED 830 | BASE @ >R BASE ! >NUMBER R> BASE ! ; 831 | : GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO. 832 | BASE @ >R BASE ! 833 | <# #S #> 834 | 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY 835 | R> BASE ! ; 836 | : GN2 \ ( -- 16 10 ) 837 | BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; 838 | 839 | : test-format 840 | ." testing <# # #s #> hold sign base >number hex decimal" cr 841 | 842 | T{ GP1 -> }T 843 | T{ GP2 -> }T 844 | T{ GP3 -> }T 845 | T{ GP4 -> }T 846 | T{ GP5 -> }T 847 | T{ GP6 -> }T 848 | T{ GP7 -> }T 849 | 850 | \ >NUMBER TESTS 851 | T{ 0 0 '0' GN' >NUMBER -> 0 0 GN-CONSUMED }T 852 | T{ 0 0 '1' GN' >NUMBER -> 1 0 GN-CONSUMED }T 853 | T{ 1 0 '1' GN' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T 854 | T{ 0 0 '-' GN' >NUMBER -> 0 0 GN-STRING }T \ SHOULD FAIL TO CONVERT THESE 855 | T{ 0 0 '+' GN' >NUMBER -> 0 0 GN-STRING }T 856 | T{ 0 0 '.' GN' >NUMBER -> 0 0 GN-STRING }T 857 | 858 | T{ 0 0 '2' GN' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T 859 | T{ 0 0 '2' GN' 2 >NUMBER-BASED -> 0 0 GN-STRING }T 860 | T{ 0 0 'F' GN' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T 861 | T{ 0 0 'G' GN' 10 >NUMBER-BASED -> 0 0 GN-STRING }T 862 | T{ 0 0 'G' GN' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T 863 | T{ 0 0 'Z' GN' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T 864 | 865 | T{ 0 0 2 GN1 -> 0 0 0 }T 866 | T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T 867 | T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T 868 | T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T 869 | T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T 870 | T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T 871 | 872 | T{ GN2 -> 10 A }T ; 873 | 874 | \ ----- 875 | 876 | CREATE FBUF 00 C, 00 C, 00 C, 877 | CREATE SBUF 12 C, 34 C, 56 C, 878 | : SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; 879 | 880 | : test-fill-move 881 | ." testing fill move" cr 882 | 883 | T{ FBUF 0 20 FILL -> }T 884 | T{ SEEBUF -> 00 00 00 }T 885 | 886 | T{ FBUF 1 20 FILL -> }T 887 | T{ SEEBUF -> 20 00 00 }T 888 | 889 | T{ FBUF 3 20 FILL -> }T 890 | T{ SEEBUF -> 20 20 20 }T 891 | 892 | T{ FBUF FBUF 3 CHARS MOVE -> }T \ BIZARRE SPECIAL CASE 893 | T{ SEEBUF -> 20 20 20 }T 894 | 895 | T{ SBUF FBUF 0 CHARS MOVE -> }T 896 | T{ SEEBUF -> 20 20 20 }T 897 | 898 | T{ SBUF FBUF 1 CHARS MOVE -> }T 899 | T{ SEEBUF -> 12 20 20 }T 900 | 901 | T{ SBUF FBUF 3 CHARS MOVE -> }T 902 | T{ SEEBUF -> 12 34 56 }T 903 | 904 | T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T 905 | T{ SEEBUF -> 12 12 34 }T 906 | 907 | T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T 908 | T{ SEEBUF -> 12 34 34 }T ; 909 | 910 | \ ----- 911 | 912 | : OUTPUT-TEST 913 | ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR 914 | 41 BL DO I EMIT LOOP CR 915 | 61 41 DO I EMIT LOOP CR 916 | 7F 61 DO I EMIT LOOP CR 917 | ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR 918 | 9 1+ 0 DO I . LOOP CR 919 | ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR 920 | [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR 921 | ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR 922 | [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR 923 | ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR 924 | 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR 925 | ." YOU SHOULD SEE TWO SEPARATE LINES:" CR 926 | S" LINE 1" TYPE CR S" LINE 2" TYPE CR 927 | ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR 928 | ." SIGNED: " MIN-INT . MAX-INT . CR 929 | ." UNSIGNED: " 0 U. MAX-UINT U. CR 930 | ; 931 | 932 | \ ----- 933 | 934 | CREATE ABUF 50 CHARS ALLOT 935 | 936 | : ACCEPT-TEST 937 | CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR 938 | ABUF 50 ACCEPT 939 | CR ." RECEIVED: " [CHAR] " EMIT 940 | ABUF SWAP TYPE [CHAR] " EMIT CR 941 | ; 942 | 943 | \ ----- testcoreplus.fs 944 | 945 | DECIMAL 946 | 947 | VARIABLE ITERATIONS 948 | VARIABLE INCREMENT 949 | : GD7 ( LIMIT START INCREMENT -- ) 950 | INCREMENT ! 951 | 0 ITERATIONS ! 952 | DO 953 | 1 ITERATIONS +! 954 | I 955 | ITERATIONS @ 6 = IF LEAVE THEN 956 | INCREMENT @ 957 | +LOOP ITERATIONS @ 958 | ; 959 | 960 | : test+doloop1 961 | ." TESTING DO +LOOP with run-time increment, negative increment, infinite loop" cr 962 | T{ 4 4 -1 GD7 -> 4 1 }T 963 | T{ 1 4 -1 GD7 -> 4 3 2 1 4 }T 964 | T{ 4 1 -1 GD7 -> 1 0 -1 -2 -3 -4 6 }T 965 | T{ 4 1 0 GD7 -> 1 1 1 1 1 1 6 }T 966 | T{ 0 0 0 GD7 -> 0 0 0 0 0 0 6 }T 967 | T{ 1 4 0 GD7 -> 4 4 4 4 4 4 6 }T 968 | T{ 1 4 1 GD7 -> 4 5 6 7 8 9 6 }T 969 | T{ 4 1 1 GD7 -> 1 2 3 3 }T 970 | T{ 4 4 1 GD7 -> 4 5 6 7 8 9 6 }T 971 | T{ 2 -1 -1 GD7 -> -1 -2 -3 -4 -5 -6 6 }T 972 | T{ -1 2 -1 GD7 -> 2 1 0 -1 4 }T 973 | T{ 2 -1 0 GD7 -> -1 -1 -1 -1 -1 -1 6 }T 974 | T{ -1 2 0 GD7 -> 2 2 2 2 2 2 6 }T 975 | T{ -1 2 1 GD7 -> 2 3 4 5 6 7 6 }T 976 | T{ 2 -1 1 GD7 -> -1 0 1 3 }T 977 | T{ -20 30 -10 GD7 -> 30 20 10 0 -10 -20 6 }T 978 | T{ -20 31 -10 GD7 -> 31 21 11 1 -9 -19 6 }T 979 | T{ -20 29 -10 GD7 -> 29 19 9 -1 -11 5 }T ; 980 | 981 | \ ----- 982 | 983 | \ Contributed by Andrew Haley 984 | 985 | MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP 986 | USTEP NEGATE CONSTANT -USTEP 987 | MAX-INT 7 RSHIFT 1+ CONSTANT STEP 988 | STEP NEGATE CONSTANT -STEP 989 | 990 | VARIABLE BUMP 991 | 992 | T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; -> }T 993 | 994 | \ Two's complement arithmetic, wraps around modulo wordsize 995 | \ Only tested if the Forth system does wrap around, use of conditional 996 | \ compilation deliberately avoided 997 | 998 | MAX-INT 1+ MIN-INT = CONSTANT +WRAP? 999 | MIN-INT 1- MAX-INT = CONSTANT -WRAP? 1000 | MAX-UINT 1+ 0= CONSTANT +UWRAP? 1001 | 0 1- MAX-UINT = CONSTANT -UWRAP? 1002 | 1003 | : GD9 ( n limit start step f result -- ) 1004 | >R IF GD8 ELSE 2DROP 2DROP R@ THEN -> R> }T 1005 | ; 1006 | 1007 | : test+doloop-largesmall 1008 | ." TESTING DO +LOOP with large and small increments" cr 1009 | 1010 | T{ 0 MAX-UINT 0 USTEP GD8 -> 256 }T 1011 | T{ 0 0 MAX-UINT -USTEP GD8 -> 256 }T 1012 | T{ 0 MAX-INT MIN-INT STEP GD8 -> 256 }T 1013 | T{ 0 MIN-INT MAX-INT -STEP GD8 -> 256 }T 1014 | 1015 | T{ 0 0 0 USTEP +UWRAP? 256 GD9 1016 | T{ 0 0 0 -USTEP -UWRAP? 1 GD9 1017 | T{ 0 MIN-INT MAX-INT STEP +WRAP? 1 GD9 1018 | T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9 ; 1019 | 1020 | \ ----- 1021 | 1022 | : (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ; 1023 | (-MI) CONSTANT -MAX-INT 1024 | 1025 | : test+doloop-maxmin 1026 | ." TESTING DO +LOOP with maximum and minimum increments" cr 1027 | 1028 | T{ 0 1 0 MAX-INT GD8 -> 1 }T 1029 | T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8 -> 2 }T 1030 | 1031 | T{ 0 MAX-INT 0 MAX-INT GD8 -> 1 }T 1032 | T{ 0 MAX-INT 1 MAX-INT GD8 -> 1 }T 1033 | T{ 0 MAX-INT -1 MAX-INT GD8 -> 2 }T 1034 | T{ 0 MAX-INT DUP 1- MAX-INT GD8 -> 1 }T 1035 | 1036 | T{ 0 MIN-INT 1+ 0 MIN-INT GD8 -> 1 }T 1037 | T{ 0 MIN-INT 1+ -1 MIN-INT GD8 -> 1 }T 1038 | T{ 0 MIN-INT 1+ 1 MIN-INT GD8 -> 2 }T 1039 | T{ 0 MIN-INT 1+ DUP MIN-INT GD8 -> 1 }T ; 1040 | 1041 | \ ----- 1042 | 1043 | : SET-I ( n1 n2 n3 -- n1-n2 | 1 ) 1044 | OVER = IF - ELSE 2DROP 1 THEN 1045 | ; 1046 | 1047 | : -SET-I ( n1 n2 n3 -- n1-n2 | -1 ) 1048 | SET-I DUP 1 = IF NEGATE THEN 1049 | ; 1050 | 1051 | : PL1 20 1 DO I 18 I 3 SET-I +LOOP ; 1052 | : PL2 20 1 DO I 20 I 2 SET-I +LOOP ; 1053 | : PL3 20 5 DO I 19 I 2 SET-I DUP 1 = IF DROP 0 I 6 SET-I THEN +LOOP ; 1054 | : PL4 20 1 DO I MAX-INT I 4 SET-I +LOOP ; 1055 | : PL5 -20 -1 DO I -19 I -3 -SET-I +LOOP ; 1056 | : PL6 -20 -1 DO I -21 I -4 -SET-I +LOOP ; 1057 | : PL7 -20 -1 DO I MIN-INT I -5 -SET-I +LOOP ; 1058 | : PL8 -20 -5 DO I -20 I -2 -SET-I DUP -1 = IF DROP 0 I -6 -SET-I THEN +LOOP ; 1059 | 1060 | : test+do+loop 1061 | ." TESTING +LOOP setting I to an arbitrary value" cr 1062 | 1063 | T{ PL1 -> 1 2 3 18 19 }T 1064 | T{ PL2 -> 1 2 }T 1065 | T{ PL3 -> 5 6 0 1 2 19 }T 1066 | T{ PL4 -> 1 2 3 4 }T 1067 | T{ PL5 -> -1 -2 -3 -19 -20 }T 1068 | T{ PL6 -> -1 -2 -3 -4 }T 1069 | T{ PL7 -> -1 -2 -3 -4 -5 }T 1070 | T{ PL8 -> -5 -6 0 -1 -2 -20 }T ; 1071 | 1072 | \ ----- 1073 | 1074 | : ACK ( m n -- u ) \ Ackermann function, from Rosetta Code 1075 | OVER 0= IF NIP 1+ EXIT THEN \ ack(0, n) = n+1 1076 | SWAP 1- SWAP ( -- m-1 n ) 1077 | DUP 0= IF 1+ RECURSE EXIT THEN \ ack(m, 0) = ack(m-1, 1) 1078 | 1- OVER 1+ SWAP RECURSE RECURSE \ ack(m, n) = ack(m-1, ack(m,n-1)) 1079 | ; 1080 | 1081 | : test+multirecurse 1082 | ." TESTING multiple RECURSEs in one colon definition" cr 1083 | T{ 0 0 ACK -> 1 }T 1084 | T{ 3 0 ACK -> 5 }T 1085 | T{ 2 4 ACK -> 11 }T ; 1086 | 1087 | \ ----- 1088 | 1089 | : MELSE IF 1 ELSE 2 ELSE 3 ELSE 4 ELSE 5 THEN ; 1090 | : test+melse 1091 | ." TESTING multiple ELSE's in an IF statement" cr 1092 | \ Discussed on comp.lang.forth and accepted as valid ANS Forth 1093 | T{ 0 MELSE -> 2 4 }T 1094 | T{ -1 MELSE -> 1 3 5 }T ; 1095 | 1096 | \ ----- 1097 | 1098 | 123 CONSTANT IW1 IMMEDIATE 1099 | : IW2 IW1 LITERAL ; 1100 | VARIABLE IW3 IMMEDIATE 234 IW3 ! 1101 | : IW4 IW3 [ @ ] LITERAL ; 1102 | variable IW3-noname immediate 1103 | :NONAME [ 345 ] IW3-noname [ ! ] ; DROP 1104 | CREATE IW5 456 , IMMEDIATE 1105 | variable IW35 1106 | :NONAME IW5 [ @ IW35 ! ] ; DROP 1107 | : IW6 CREATE , IMMEDIATE DOES> @ 1+ ; 1108 | 111 IW6 IW7 1109 | : IW8 IW7 LITERAL 1+ ; 1110 | 1111 | : test+immediate 1112 | ." TESTING IMMEDIATE with CONSTANT VARIABLE and CREATE [ ... DOES> ]" cr 1113 | 1114 | T{ postpone IW1 -> 123 }T 1115 | T{ IW2 -> 123 }T 1116 | T{ postpone IW3 @ -> 234 }T 1117 | T{ IW4 -> 234 }T 1118 | T{ postpone IW3-noname @ -> 345 }T 1119 | T{ IW35 @ -> 456 }T 1120 | T{ postpone IW7 -> 112 }T 1121 | T{ IW8 -> 113 }T ; 1122 | 1123 | \ ----- 1124 | 1125 | VARIABLE IT1 0 IT1 ! 1126 | : IT2 1234 IT1 ! ; IMMEDIATE IMMEDIATE 1127 | : IT3 IT2 ; 1128 | 1129 | : test+immediate-toggle 1130 | ." TESTING that IMMEDIATE doesn't toggle a flag" cr 1131 | T{ IT1 @ -> 1234 }T ; 1132 | 1133 | \ ----- 1134 | 1135 | T{ : GC5 S" A string"2DROP ; GC5 -> }T 1136 | T{ ( A comment)1234 -> 1234 }T 1137 | : PB1 CR ." You should see 2345: "." 2345"( A comment) CR ; 1138 | 1139 | : test+parse 1140 | ." TESTING parsing behaviour" 1141 | T{ GC5 -> }T 1142 | T{ PB1 -> }T ; 1143 | 1144 | \ ----- 1145 | 1146 | VARIABLE OLD-BASE 1147 | 1148 | \ Check number prefixes in compile mode 1149 | T{ : nmp #8327 $-2cbe %011010111 ''' ; nmp -> 8327 -11454 215 39 }T 1150 | 1151 | : test+number-prefixes 1152 | ." TESTING number prefixes # $ % and 'c' character input" cr 1153 | \ Adapted from the Forth 200X Draft 14.5 document 1154 | 1155 | DECIMAL BASE @ OLD-BASE ! 1156 | T{ #1289 -> 1289 }T 1157 | T{ #-1289 -> -1289 }T 1158 | T{ $12eF -> 4847 }T 1159 | T{ $-12eF -> -4847 }T 1160 | T{ %10010110 -> 150 }T 1161 | T{ %-10010110 -> -150 }T 1162 | T{ 'z' -> #90 }T \ petscii 1163 | T{ 'Z' -> #218 }T \ petscii 1164 | \ Check BASE is unchanged 1165 | T{ BASE @ OLD-BASE @ = -> }T 1166 | 1167 | \ Repeat in Hex mode 1168 | 16 OLD-BASE ! 16 BASE ! [ 16 base ! ] 1169 | T{ #1289 -> 509 }T 1170 | T{ #-1289 -> -509 }T 1171 | T{ $12eF -> 12EF }T 1172 | T{ $-12eF -> -12EF }T 1173 | T{ %10010110 -> 96 }T 1174 | T{ %-10010110 -> -96 }T 1175 | T{ 'z' -> #90 }T \ petscii 1176 | T{ 'Z' -> #218 }T \ petscii 1177 | \ Check BASE is unchanged 1178 | T{ BASE @ OLD-BASE @ = -> }T \ 2 1179 | DECIMAL [ DECIMAL ] 1180 | T{ nmp -> 8327 -11454 215 39 }T 1181 | ; 1182 | 1183 | \ ----- 1184 | 1185 | : !"#$%&'()*+,-./0123456789:;<=>? 1 ; 1186 | : @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ 2 ; 1187 | : _`abcdefghijklmnopqrstuvwxyz{|} 3 ; 1188 | : _`abcdefghijklmnopqrstuvwxyz{|~ 4 ; \ Last character different 1189 | 1190 | : test+definition-names 1191 | ." TESTING definition names" cr 1192 | \ should support {1..31} graphical characters 1193 | T{ !"#$%&'()*+,-./0123456789:;<=>? -> 1 }T 1194 | T{ @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ -> 2 }T 1195 | T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T 1196 | T{ _`abcdefghijklmnopqrstuvwxyz{|~ -> 4 }T 1197 | T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T ; 1198 | 1199 | \ ----- 1200 | 1201 | T{ : UNS1 DUP 0 > IF 9 SWAP BEGIN 1+ DUP 3 > IF EXIT THEN REPEAT ; -> }T 1202 | 1203 | : test+if-begin-repeat 1204 | ." TESTING IF ... BEGIN ... REPEAT (unstructured)" cr 1205 | T{ -6 UNS1 -> -6 }T 1206 | T{ 1 UNS1 -> 9 4 }T ; 1207 | 1208 | \ ----- 1209 | 1210 | : MAKE-2CONST DOES> 2@ ; 1211 | CREATE 2K 3 , 2K , MAKE-2CONST 1212 | 1213 | : test+does> 1214 | ." TESTING DOES> doesn't cause a problem with a CREATEd address" cr 1215 | T{ 2K -> ['] 2K >BODY 3 }T 1216 | ; 1217 | 1218 | \ ----- testcoreext.fs 1219 | 1220 | DECIMAL 1221 | 1222 | : test.true-false 1223 | ." TESTING TRUE FALSE" cr 1224 | T{ TRUE -> 0 INVERT }T 1225 | T{ FALSE -> 0 }T ; 1226 | 1227 | \ ----- 1228 | 1229 | : test.<>u> 1230 | ." TESTING <> U> (contributed by James Bowman)" cr 1231 | 1232 | T{ 0 0 <> -> FALSE }T 1233 | T{ 1 1 <> -> FALSE }T 1234 | T{ -1 -1 <> -> FALSE }T 1235 | T{ 1 0 <> -> TRUE }T 1236 | T{ -1 0 <> -> TRUE }T 1237 | T{ 0 1 <> -> TRUE }T 1238 | T{ 0 -1 <> -> TRUE }T 1239 | 1240 | T{ 0 1 U> -> FALSE }T 1241 | T{ 1 2 U> -> FALSE }T 1242 | T{ 0 MID-UINT U> -> FALSE }T 1243 | T{ 0 MAX-UINT U> -> FALSE }T 1244 | T{ MID-UINT MAX-UINT U> -> FALSE }T 1245 | T{ 0 0 U> -> FALSE }T 1246 | T{ 1 1 U> -> FALSE }T 1247 | T{ 1 0 U> -> TRUE }T 1248 | T{ 2 1 U> -> TRUE }T 1249 | T{ MID-UINT 0 U> -> TRUE }T 1250 | T{ MAX-UINT 0 U> -> TRUE }T 1251 | T{ MAX-UINT MID-UINT U> -> TRUE }T ; 1252 | 1253 | \ ----- 1254 | 1255 | : test.0<>0> 1256 | ." TESTING 0<> 0> (contributed by James Bowman)" cr 1257 | 1258 | T{ 0 0<> -> FALSE }T 1259 | T{ 1 0<> -> TRUE }T 1260 | T{ 2 0<> -> TRUE }T 1261 | T{ -1 0<> -> TRUE }T 1262 | T{ MAX-UINT 0<> -> TRUE }T 1263 | T{ MIN-INT 0<> -> TRUE }T 1264 | T{ MAX-INT 0<> -> TRUE }T 1265 | 1266 | T{ 0 0> -> FALSE }T 1267 | T{ -1 0> -> FALSE }T 1268 | T{ MIN-INT 0> -> FALSE }T 1269 | T{ 1 0> -> TRUE }T 1270 | T{ MAX-INT 0> -> TRUE }T ; 1271 | 1272 | \ ----- 1273 | 1274 | T{ : RO5 100 200 300 400 500 ; -> }T 1275 | 1276 | : test.niptuckrollpick 1277 | ." TESTING NIP TUCK ROLL PICK (contributed by James Bowman)" cr 1278 | 1279 | T{ 1 2 NIP -> 2 }T 1280 | T{ 1 2 3 NIP -> 1 3 }T 1281 | 1282 | T{ 1 2 TUCK -> 2 1 2 }T 1283 | T{ 1 2 3 TUCK -> 1 3 2 3 }T 1284 | 1285 | T{ RO5 3 ROLL -> 100 300 400 500 200 }T 1286 | T{ RO5 2 ROLL -> RO5 ROT }T 1287 | T{ RO5 1 ROLL -> RO5 SWAP }T 1288 | T{ RO5 0 ROLL -> RO5 }T 1289 | 1290 | T{ RO5 2 PICK -> 100 200 300 400 500 300 }T 1291 | T{ RO5 1 PICK -> RO5 OVER }T 1292 | T{ RO5 0 PICK -> RO5 DUP }T ; 1293 | 1294 | \ ----- 1295 | 1296 | T{ : RR0 2>R 100 R> R> ; -> }T 1297 | T{ : RR1 2>R 100 2R@ R> R> ; -> }T 1298 | T{ : RR2 2>R 100 2R> ; -> }T 1299 | 1300 | : test.2>r2r@2r> 1301 | ." TESTING 2>R 2R@ 2R> (contributed by James Bowman)" cr 1302 | 1303 | T{ 300 400 RR0 -> 100 400 300 }T 1304 | T{ 200 300 400 RR0 -> 200 100 400 300 }T 1305 | 1306 | T{ 300 400 RR1 -> 100 300 400 400 300 }T 1307 | T{ 200 300 400 RR1 -> 200 100 300 400 400 300 }T 1308 | 1309 | T{ 300 400 RR2 -> 100 300 400 }T 1310 | T{ 200 300 400 RR2 -> 200 100 300 400 }T ; 1311 | 1312 | \ ----- 1313 | 1314 | : test.hex 1315 | ." TESTING HEX (contributed by James Bowman)" cr 1316 | 1317 | T{ BASE @ HEX BASE @ DECIMAL BASE @ - SWAP BASE ! -> 6 }T ; 1318 | 1319 | \ ----- 1320 | 1321 | : test.within 1322 | ." TESTING WITHIN (contributed by James Bowman)" cr 1323 | 1324 | T{ 0 0 0 WITHIN -> FALSE }T 1325 | T{ 0 0 MID-UINT WITHIN -> TRUE }T 1326 | T{ 0 0 MID-UINT+1 WITHIN -> TRUE }T 1327 | T{ 0 0 MAX-UINT WITHIN -> TRUE }T 1328 | T{ 0 MID-UINT 0 WITHIN -> FALSE }T 1329 | T{ 0 MID-UINT MID-UINT WITHIN -> FALSE }T 1330 | T{ 0 MID-UINT MID-UINT+1 WITHIN -> FALSE }T 1331 | T{ 0 MID-UINT MAX-UINT WITHIN -> FALSE }T 1332 | T{ 0 MID-UINT+1 0 WITHIN -> FALSE }T 1333 | T{ 0 MID-UINT+1 MID-UINT WITHIN -> TRUE }T 1334 | T{ 0 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T 1335 | T{ 0 MID-UINT+1 MAX-UINT WITHIN -> FALSE }T 1336 | T{ 0 MAX-UINT 0 WITHIN -> FALSE }T 1337 | T{ 0 MAX-UINT MID-UINT WITHIN -> TRUE }T 1338 | T{ 0 MAX-UINT MID-UINT+1 WITHIN -> TRUE }T 1339 | T{ 0 MAX-UINT MAX-UINT WITHIN -> FALSE }T 1340 | T{ MID-UINT 0 0 WITHIN -> FALSE }T 1341 | T{ MID-UINT 0 MID-UINT WITHIN -> FALSE }T 1342 | T{ MID-UINT 0 MID-UINT+1 WITHIN -> TRUE }T 1343 | T{ MID-UINT 0 MAX-UINT WITHIN -> TRUE }T 1344 | T{ MID-UINT MID-UINT 0 WITHIN -> TRUE }T 1345 | T{ MID-UINT MID-UINT MID-UINT WITHIN -> FALSE }T 1346 | T{ MID-UINT MID-UINT MID-UINT+1 WITHIN -> TRUE }T 1347 | T{ MID-UINT MID-UINT MAX-UINT WITHIN -> TRUE }T 1348 | T{ MID-UINT MID-UINT+1 0 WITHIN -> FALSE }T 1349 | T{ MID-UINT MID-UINT+1 MID-UINT WITHIN -> FALSE }T 1350 | T{ MID-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T 1351 | T{ MID-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T 1352 | T{ MID-UINT MAX-UINT 0 WITHIN -> FALSE }T 1353 | T{ MID-UINT MAX-UINT MID-UINT WITHIN -> FALSE }T 1354 | T{ MID-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T 1355 | T{ MID-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T 1356 | T{ MID-UINT+1 0 0 WITHIN -> FALSE }T 1357 | T{ MID-UINT+1 0 MID-UINT WITHIN -> FALSE }T 1358 | T{ MID-UINT+1 0 MID-UINT+1 WITHIN -> FALSE }T 1359 | T{ MID-UINT+1 0 MAX-UINT WITHIN -> TRUE }T 1360 | T{ MID-UINT+1 MID-UINT 0 WITHIN -> TRUE }T 1361 | T{ MID-UINT+1 MID-UINT MID-UINT WITHIN -> FALSE }T 1362 | T{ MID-UINT+1 MID-UINT MID-UINT+1 WITHIN -> FALSE }T 1363 | T{ MID-UINT+1 MID-UINT MAX-UINT WITHIN -> TRUE }T 1364 | T{ MID-UINT+1 MID-UINT+1 0 WITHIN -> TRUE }T 1365 | T{ MID-UINT+1 MID-UINT+1 MID-UINT WITHIN -> TRUE }T 1366 | T{ MID-UINT+1 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T 1367 | T{ MID-UINT+1 MID-UINT+1 MAX-UINT WITHIN -> TRUE }T 1368 | T{ MID-UINT+1 MAX-UINT 0 WITHIN -> FALSE }T 1369 | T{ MID-UINT+1 MAX-UINT MID-UINT WITHIN -> FALSE }T 1370 | T{ MID-UINT+1 MAX-UINT MID-UINT+1 WITHIN -> FALSE }T 1371 | T{ MID-UINT+1 MAX-UINT MAX-UINT WITHIN -> FALSE }T 1372 | T{ MAX-UINT 0 0 WITHIN -> FALSE }T 1373 | T{ MAX-UINT 0 MID-UINT WITHIN -> FALSE }T 1374 | T{ MAX-UINT 0 MID-UINT+1 WITHIN -> FALSE }T 1375 | T{ MAX-UINT 0 MAX-UINT WITHIN -> FALSE }T 1376 | T{ MAX-UINT MID-UINT 0 WITHIN -> TRUE }T 1377 | T{ MAX-UINT MID-UINT MID-UINT WITHIN -> FALSE }T 1378 | T{ MAX-UINT MID-UINT MID-UINT+1 WITHIN -> FALSE }T 1379 | T{ MAX-UINT MID-UINT MAX-UINT WITHIN -> FALSE }T 1380 | T{ MAX-UINT MID-UINT+1 0 WITHIN -> TRUE }T 1381 | T{ MAX-UINT MID-UINT+1 MID-UINT WITHIN -> TRUE }T 1382 | T{ MAX-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T 1383 | T{ MAX-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T 1384 | T{ MAX-UINT MAX-UINT 0 WITHIN -> TRUE }T 1385 | T{ MAX-UINT MAX-UINT MID-UINT WITHIN -> TRUE }T 1386 | T{ MAX-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T 1387 | T{ MAX-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T 1388 | 1389 | T{ MIN-INT MIN-INT MIN-INT WITHIN -> FALSE }T 1390 | T{ MIN-INT MIN-INT 0 WITHIN -> TRUE }T 1391 | T{ MIN-INT MIN-INT 1 WITHIN -> TRUE }T 1392 | T{ MIN-INT MIN-INT MAX-INT WITHIN -> TRUE }T 1393 | T{ MIN-INT 0 MIN-INT WITHIN -> FALSE }T 1394 | T{ MIN-INT 0 0 WITHIN -> FALSE }T 1395 | T{ MIN-INT 0 1 WITHIN -> FALSE }T 1396 | T{ MIN-INT 0 MAX-INT WITHIN -> FALSE }T 1397 | T{ MIN-INT 1 MIN-INT WITHIN -> FALSE }T 1398 | T{ MIN-INT 1 0 WITHIN -> TRUE }T 1399 | T{ MIN-INT 1 1 WITHIN -> FALSE }T 1400 | T{ MIN-INT 1 MAX-INT WITHIN -> FALSE }T 1401 | T{ MIN-INT MAX-INT MIN-INT WITHIN -> FALSE }T 1402 | T{ MIN-INT MAX-INT 0 WITHIN -> TRUE }T 1403 | T{ MIN-INT MAX-INT 1 WITHIN -> TRUE }T 1404 | T{ MIN-INT MAX-INT MAX-INT WITHIN -> FALSE }T 1405 | T{ 0 MIN-INT MIN-INT WITHIN -> FALSE }T 1406 | T{ 0 MIN-INT 0 WITHIN -> FALSE }T 1407 | T{ 0 MIN-INT 1 WITHIN -> TRUE }T 1408 | T{ 0 MIN-INT MAX-INT WITHIN -> TRUE }T 1409 | T{ 0 0 MIN-INT WITHIN -> TRUE }T 1410 | T{ 0 0 0 WITHIN -> FALSE }T 1411 | T{ 0 0 1 WITHIN -> TRUE }T 1412 | T{ 0 0 MAX-INT WITHIN -> TRUE }T 1413 | T{ 0 1 MIN-INT WITHIN -> FALSE }T 1414 | T{ 0 1 0 WITHIN -> FALSE }T 1415 | T{ 0 1 1 WITHIN -> FALSE }T 1416 | T{ 0 1 MAX-INT WITHIN -> FALSE }T 1417 | T{ 0 MAX-INT MIN-INT WITHIN -> FALSE }T 1418 | T{ 0 MAX-INT 0 WITHIN -> FALSE }T 1419 | T{ 0 MAX-INT 1 WITHIN -> TRUE }T 1420 | T{ 0 MAX-INT MAX-INT WITHIN -> FALSE }T 1421 | T{ 1 MIN-INT MIN-INT WITHIN -> FALSE }T 1422 | T{ 1 MIN-INT 0 WITHIN -> FALSE }T 1423 | T{ 1 MIN-INT 1 WITHIN -> FALSE }T 1424 | T{ 1 MIN-INT MAX-INT WITHIN -> TRUE }T 1425 | T{ 1 0 MIN-INT WITHIN -> TRUE }T 1426 | T{ 1 0 0 WITHIN -> FALSE }T 1427 | T{ 1 0 1 WITHIN -> FALSE }T 1428 | T{ 1 0 MAX-INT WITHIN -> TRUE }T 1429 | T{ 1 1 MIN-INT WITHIN -> TRUE }T 1430 | T{ 1 1 0 WITHIN -> TRUE }T 1431 | T{ 1 1 1 WITHIN -> FALSE }T 1432 | T{ 1 1 MAX-INT WITHIN -> TRUE }T 1433 | T{ 1 MAX-INT MIN-INT WITHIN -> FALSE }T 1434 | T{ 1 MAX-INT 0 WITHIN -> FALSE }T 1435 | T{ 1 MAX-INT 1 WITHIN -> FALSE }T 1436 | T{ 1 MAX-INT MAX-INT WITHIN -> FALSE }T 1437 | T{ MAX-INT MIN-INT MIN-INT WITHIN -> FALSE }T 1438 | T{ MAX-INT MIN-INT 0 WITHIN -> FALSE }T 1439 | T{ MAX-INT MIN-INT 1 WITHIN -> FALSE }T 1440 | T{ MAX-INT MIN-INT MAX-INT WITHIN -> FALSE }T 1441 | T{ MAX-INT 0 MIN-INT WITHIN -> TRUE }T 1442 | T{ MAX-INT 0 0 WITHIN -> FALSE }T 1443 | T{ MAX-INT 0 1 WITHIN -> FALSE }T 1444 | T{ MAX-INT 0 MAX-INT WITHIN -> FALSE }T 1445 | T{ MAX-INT 1 MIN-INT WITHIN -> TRUE }T 1446 | T{ MAX-INT 1 0 WITHIN -> TRUE }T 1447 | T{ MAX-INT 1 1 WITHIN -> FALSE }T 1448 | T{ MAX-INT 1 MAX-INT WITHIN -> FALSE }T 1449 | T{ MAX-INT MAX-INT MIN-INT WITHIN -> TRUE }T 1450 | T{ MAX-INT MAX-INT 0 WITHIN -> TRUE }T 1451 | T{ MAX-INT MAX-INT 1 WITHIN -> TRUE }T 1452 | T{ MAX-INT MAX-INT MAX-INT WITHIN -> FALSE }T ; 1453 | 1454 | \ ----- 1455 | 1456 | \ unused not tested, since HERE does not exist 1457 | 1458 | \ ----- 1459 | 1460 | T{ : AG0 701 BEGIN DUP 7 MOD 0= IF EXIT THEN 1+ AGAIN ; -> }T 1461 | : test.again 1462 | ." TESTING AGAIN (contributed by James Bowman)" cr 1463 | T{ AG0 -> 707 }T ; 1464 | 1465 | \ ----- 1466 | 1467 | : QD ?DO I LOOP ; 1468 | : QD1 ?DO I 10 +LOOP ; 1469 | : QD2 ?DO I 3 > IF LEAVE ELSE I THEN LOOP ; 1470 | : QD3 ?DO I 1 +LOOP ; 1471 | : QD4 ?DO I -1 +LOOP ; 1472 | : QD5 ?DO I -10 +LOOP ; 1473 | VARIABLE ITERS 1474 | VARIABLE INCRMNT 1475 | : QD6 ( limit start increment -- ) 1476 | INCRMNT ! 1477 | 0 ITERS ! 1478 | ?DO 1479 | 1 ITERS +! 1480 | I 1481 | ITERS @ 6 = IF LEAVE THEN 1482 | INCRMNT @ 1483 | +LOOP ITERS @ 1484 | ; 1485 | 1486 | : test.?do 1487 | ." TESTING ?DO" cr 1488 | 1489 | T{ 789 789 QD -> }T 1490 | T{ -9876 -9876 QD -> }T 1491 | T{ 5 0 QD -> 0 1 2 3 4 }T 1492 | 1493 | T{ 50 1 QD1 -> 1 11 21 31 41 }T 1494 | T{ 50 0 QD1 -> 0 10 20 30 40 }T 1495 | 1496 | T{ 5 -1 QD2 -> -1 0 1 2 3 }T 1497 | 1498 | T{ 4 4 QD3 -> }T 1499 | T{ 4 1 QD3 -> 1 2 3 }T 1500 | T{ 2 -1 QD3 -> -1 0 1 }T 1501 | 1502 | T{ 4 4 QD4 -> }T 1503 | T{ 1 4 QD4 -> 4 3 2 1 }T 1504 | T{ -1 2 QD4 -> 2 1 0 -1 }T 1505 | 1506 | T{ 1 50 QD5 -> 50 40 30 20 10 }T 1507 | T{ 0 50 QD5 -> 50 40 30 20 10 0 }T 1508 | T{ -25 10 QD5 -> 10 0 -10 -20 }T 1509 | 1510 | T{ 4 4 -1 QD6 -> 0 }T 1511 | T{ 1 4 -1 QD6 -> 4 3 2 1 4 }T 1512 | T{ 4 1 -1 QD6 -> 1 0 -1 -2 -3 -4 6 }T 1513 | T{ 4 1 0 QD6 -> 1 1 1 1 1 1 6 }T 1514 | T{ 0 0 0 QD6 -> 0 }T 1515 | T{ 1 4 0 QD6 -> 4 4 4 4 4 4 6 }T 1516 | T{ 1 4 1 QD6 -> 4 5 6 7 8 9 6 }T 1517 | T{ 4 1 1 QD6 -> 1 2 3 3 }T 1518 | T{ 4 4 1 QD6 -> 0 }T 1519 | T{ 2 -1 -1 QD6 -> -1 -2 -3 -4 -5 -6 6 }T 1520 | T{ -1 2 -1 QD6 -> 2 1 0 -1 4 }T 1521 | T{ 2 -1 0 QD6 -> -1 -1 -1 -1 -1 -1 6 }T 1522 | T{ -1 2 0 QD6 -> 2 2 2 2 2 2 6 }T 1523 | T{ -1 2 1 QD6 -> 2 3 4 5 6 7 6 }T 1524 | T{ 2 -1 1 QD6 -> -1 0 1 3 }T ; 1525 | 1526 | \ ----- 1527 | 1528 | T{ 8 BUFFER: BUF:TEST -> }T 1529 | 1530 | : test.buffer: 1531 | ." TESTING BUFFER:" cr 1532 | T{ BUF:TEST DUP ALIGNED = -> TRUE }T 1533 | T{ 111 BUF:TEST ! 222 BUF:TEST CELL+ ! -> }T 1534 | T{ BUF:TEST @ BUF:TEST CELL+ @ -> 111 222 }T ; 1535 | 1536 | \ ----- 1537 | 1538 | T{ 111 VALUE VAL1 -999 VALUE VAL2 -> }T 1539 | T{ : VD1 VAL1 ; -> }T 1540 | T{ : VD2 TO VAL2 ; -> }T 1541 | T{ 123 VALUE VAL3 IMMEDIATE VAL3 -> 123 }T 1542 | T{ : VD3 VAL3 LITERAL ; -> }T 1543 | 1544 | : test.value-to 1545 | ." TESTING VALUE TO" cr 1546 | T{ VAL1 -> 111 }T 1547 | T{ VAL2 -> -999 }T 1548 | T{ 222 TO VAL1 -> }T 1549 | T{ VAL1 -> 222 }T 1550 | T{ VD1 -> 222 }T 1551 | T{ VAL2 -> -999 }T 1552 | T{ -333 VD2 -> }T 1553 | T{ VAL2 -> -333 }T 1554 | T{ VAL1 -> 222 }T 1555 | T{ VD3 -> 123 }T ; 1556 | 1557 | \ ----- 1558 | 1559 | : CS1 CASE 1 OF 111 ENDOF 1560 | 2 OF 222 ENDOF 1561 | 3 OF 333 ENDOF 1562 | >R 999 R> 1563 | ENDCASE ; 1564 | 1565 | : CS2 >R CASE -1 OF CASE R@ 1 OF 100 ENDOF 1566 | 2 OF 200 ENDOF 1567 | >R -300 R> 1568 | ENDCASE 1569 | ENDOF 1570 | -2 OF CASE R@ 1 OF -99 ENDOF 1571 | >R -199 R> 1572 | ENDCASE 1573 | ENDOF 1574 | >R 299 R> 1575 | ENDCASE R> DROP ; 1576 | 1577 | : CS3 ( N1 -- N2 ) 1578 | CASE 1- FALSE OF 11 ENDOF 1579 | 1- FALSE OF 22 ENDOF 1580 | 1- FALSE OF 33 ENDOF 1581 | 44 SWAP 1582 | ENDCASE ; 1583 | 1584 | T{ : CS4 CASE ENDCASE ; -> }T 1585 | T{ : CS5 CASE 2 SWAP ENDCASE ; -> }T 1586 | T{ : CS6 CASE 1 OF ENDOF 2 ENDCASE ; -> }T 1587 | T{ : CS7 CASE 3 OF ENDOF 2 ENDCASE ; -> }T 1588 | 1589 | : test.caseof 1590 | ." TESTING CASE OF ENDOF ENDCASE" cr 1591 | 1592 | T{ 1 CS1 -> 111 }T 1593 | T{ 2 CS1 -> 222 }T 1594 | T{ 3 CS1 -> 333 }T 1595 | T{ 4 CS1 -> 999 }T 1596 | 1597 | \ Nested CASE's 1598 | 1599 | T{ -1 1 CS2 -> 100 }T 1600 | T{ -1 2 CS2 -> 200 }T 1601 | T{ -1 3 CS2 -> -300 }T 1602 | T{ -2 1 CS2 -> -99 }T 1603 | T{ -2 2 CS2 -> -199 }T 1604 | T{ 0 2 CS2 -> 299 }T 1605 | 1606 | \ Boolean short circuiting using CASE 1607 | 1608 | T{ 1 CS3 -> 11 }T 1609 | T{ 2 CS3 -> 22 }T 1610 | T{ 3 CS3 -> 33 }T 1611 | T{ 9 CS3 -> 44 }T 1612 | 1613 | \ Empty CASE statements with/without default 1614 | 1615 | T{ 1 CS4 -> }T 1616 | T{ 1 CS5 -> 2 }T 1617 | T{ 1 CS6 -> }T 1618 | T{ 1 CS7 -> 1 }T ; 1619 | 1620 | \ ----- 1621 | 1622 | VARIABLE NN1 1623 | VARIABLE NN2 1624 | :NONAME 1234 ; NN1 ! 1625 | :NONAME 9876 ; NN2 ! 1626 | 1627 | T{ :NONAME ( n -- 0,1,..n ) DUP IF DUP >R 1- RECURSE R> THEN ; 1628 | CONSTANT RN1 -> }T 1629 | 1630 | :NONAME ( n -- n1 ) \ Multiple RECURSEs in one definition 1631 | 1- DUP 1632 | CASE 0 OF EXIT ENDOF 1633 | 1 OF 11 SWAP RECURSE ENDOF 1634 | 2 OF 22 SWAP RECURSE ENDOF 1635 | 3 OF 33 SWAP RECURSE ENDOF 1636 | DROP ABS RECURSE EXIT 1637 | ENDCASE 1638 | ; CONSTANT RN2 1639 | 1640 | : test.noname-recurse 1641 | ." TESTING :NONAME RECURSE" cr 1642 | T{ NN1 @ EXECUTE -> 1234 }T 1643 | T{ NN2 @ EXECUTE -> 9876 }T 1644 | T{ 0 RN1 EXECUTE -> 0 }T 1645 | T{ 4 RN1 EXECUTE -> 0 1 2 3 4 }T 1646 | T{ 1 RN2 EXECUTE -> 0 }T 1647 | T{ 2 RN2 EXECUTE -> 11 0 }T 1648 | T{ 4 RN2 EXECUTE -> 33 22 11 0 }T 1649 | T{ 25 RN2 EXECUTE -> 33 22 11 0 }T ; 1650 | 1651 | \ ----- 1652 | 1653 | T{ : CQ1 C" 123" ; -> }T 1654 | T{ : CQ2 C" " ; -> }T 1655 | T{ : CQ3 C" 2345"; -> }T 1656 | 1657 | : test.cquote ." TESTING C" '"' emit cr 1658 | T{ CQ1 COUNT S" 123" S= -> TRUE }T 1659 | T{ CQ2 COUNT S" " S= -> TRUE }T 1660 | T{ CQ3 COUNT S" 2345" S= -> TRUE }T ; 1661 | 1662 | \ ----- 1663 | 1664 | :NONAME DUP + ; CONSTANT DUP+ 1665 | T{ : Q DUP+ COMPILE, ; -> }T 1666 | T{ : AS1 [ Q ] ; -> }T 1667 | 1668 | : test.compile, 1669 | ." TESTING COMPILE," cr 1670 | T{ 123 AS1 -> 246 }T ; 1671 | 1672 | \ ----- 1673 | 1674 | \ Create some large integers just below/above MAX and Min INTs 1675 | MAX-INT 73 79 */ CONSTANT LI1 1676 | MIN-INT 71 73 */ CONSTANT LI2 1677 | LI1 0 <# #S #> NIP CONSTANT LENLI1 1678 | : (.R&U.R) ( u1 u2 -- ) \ u1 <= string length, u2 is required indentation 1679 | TUCK + >R 1680 | LI1 OVER SPACES . CR R@ LI1 SWAP .R CR 1681 | LI2 OVER SPACES . CR R@ 1+ LI2 SWAP .R CR 1682 | LI1 OVER SPACES U. CR R@ LI1 SWAP U.R CR 1683 | LI2 SWAP SPACES U. CR R> LI2 SWAP U.R CR 1684 | ; 1685 | : .R&U.R ( -- ) 1686 | CR ." You should see lines duplicated:" CR 1687 | ." indented by 0 spaces" CR 0 0 (.R&U.R) CR 1688 | ." indented by 0 spaces" CR LENLI1 0 (.R&U.R) CR \ Just fits required width 1689 | ." indented by 5 spaces" CR LENLI1 5 (.R&U.R) CR 1690 | ; 1691 | 1692 | : test.ru.r 1693 | ." TESTING .R and U.R - has to handle different cell sizes" cr 1694 | CR CR ." Output from .R and U.R" 1695 | T{ .R&U.R -> }T ; 1696 | 1697 | \ ----- 1698 | 1699 | 84 CONSTANT CHARS/PAD \ Minimum size of PAD in chars 1700 | CHARS/PAD CHARS CONSTANT AUS/PAD 1701 | : CHECKPAD ( caddr u ch -- f ) \ f = TRUE if u chars = ch 1702 | SWAP 0 1703 | ?DO 1704 | OVER I CHARS + C@ OVER <> 1705 | IF 2DROP UNLOOP FALSE EXIT THEN 1706 | LOOP 1707 | 2DROP TRUE ; 1708 | T{ 0 INVERT PAD C! -> }T 1709 | T{ PAD C@ CONSTANT MAXCHAR -> }T 1710 | 1711 | : test.pad-erase 1712 | ." TESTING PAD ERASE" cr 1713 | \ Must handle different size characters i.e. 1 CHARS >= 1 1714 | 1715 | T{ PAD DROP -> }T 1716 | T{ PAD CHARS/PAD 2DUP MAXCHAR FILL MAXCHAR CHECKPAD -> TRUE }T 1717 | T{ PAD CHARS/PAD 2DUP CHARS ERASE 0 CHECKPAD -> TRUE }T 1718 | T{ PAD CHARS/PAD 2DUP MAXCHAR FILL PAD 0 ERASE MAXCHAR CHECKPAD -> TRUE }T 1719 | T{ PAD 43 CHARS + 9 CHARS ERASE -> }T 1720 | T{ PAD 43 MAXCHAR CHECKPAD -> TRUE }T 1721 | T{ PAD 43 CHARS + 9 0 CHECKPAD -> TRUE }T 1722 | T{ PAD 52 CHARS + CHARS/PAD 52 - MAXCHAR CHECKPAD -> TRUE }T 1723 | 1724 | \ Check that use of WORD and pictured numeric output do not corrupt PAD 1725 | \ Minimum size of buffers for these are 33 chars and (2*n)+2 chars respectively 1726 | \ where n is number of bits per cell 1727 | 1728 | PAD CHARS/PAD ERASE 1729 | 2 BASE ! 1730 | MAX-UINT MAX-UINT <# #S [CHAR] 1 DUP HOLD HOLD #> 2DROP 1731 | DECIMAL 1732 | \ BL WORD 12345678123456781234567812345678 DROP <-- no WORD on target! 1733 | T{ PAD CHARS/PAD 0 CHECKPAD -> TRUE }T ; 1734 | 1735 | \ ----- 1736 | 1737 | T{ DEFER DEFER1 -> }T 1738 | T{ : MY-DEFER DEFER ; -> }T 1739 | T{ : IS-DEFER1 IS DEFER1 ; -> }T 1740 | T{ : ACTION-DEFER1 ACTION-OF DEFER1 ; -> }T 1741 | T{ : DEF! DEFER! ; -> }T 1742 | T{ : DEF@ DEFER@ ; -> }T 1743 | T{ MY-DEFER DEFER2 -> }T 1744 | 1745 | : test.defer 1746 | ." TESTING DEFER DEFER@ DEFER! IS ACTION-OF (Forth 2012)" cr 1747 | \ Adapted from the Forth 200X RfD tests 1748 | 1749 | T{ ['] * ['] DEFER1 DEFER! -> }T 1750 | T{ 2 3 DEFER1 -> 6 }T 1751 | T{ ['] DEFER1 DEFER@ -> ['] * }T 1752 | T{ ['] DEFER1 DEF@ -> ['] * }T 1753 | T{ ACTION-OF DEFER1 -> ['] * }T 1754 | T{ ACTION-DEFER1 -> ['] * }T 1755 | T{ ['] + IS DEFER1 -> }T 1756 | T{ 1 2 DEFER1 -> 3 }T 1757 | T{ ['] DEFER1 DEFER@ -> ['] + }T 1758 | T{ ['] DEFER1 DEF@ -> ['] + }T 1759 | T{ ACTION-OF DEFER1 -> ['] + }T 1760 | T{ ACTION-DEFER1 -> ['] + }T 1761 | T{ ['] - IS-DEFER1 -> }T 1762 | T{ 1 2 DEFER1 -> -1 }T 1763 | T{ ['] DEFER1 DEFER@ -> ['] - }T 1764 | T{ ['] DEFER1 DEF@ -> ['] - }T 1765 | T{ ACTION-OF DEFER1 -> ['] - }T 1766 | T{ ACTION-DEFER1 -> ['] - }T 1767 | 1768 | T{ ['] DUP IS DEFER2 -> }T 1769 | T{ 1 DEFER2 -> 1 1 }T ; 1770 | 1771 | \ ---- 1772 | 1773 | : HTEST S" Testing HOLDS" ; 1774 | : HTEST2 S" works" ; 1775 | : HTEST3 S" Testing HOLDS works 123" ; 1776 | T{ : HLD HOLDS ; -> }T 1777 | 1778 | : test.holds 1779 | ." TESTING HOLDS (Forth 2012)" cr 1780 | T{ 0 0 <# HTEST HOLDS #> HTEST S= -> TRUE }T 1781 | T{ 123 0 <# #S BL HOLD HTEST2 HOLDS BL HOLD HTEST HOLDS #> 1782 | HTEST3 S= -> TRUE }T 1783 | T{ 0 0 <# HTEST HLD #> HTEST S= -> TRUE }T ; 1784 | 1785 | \ ----- 1786 | 1787 | T{ : SSQ1 S\" abc" S" abc" S= ; -> }T \ No escapes 1788 | T{ : SSQ2 S\" " ; -> }T \ Empty string 1789 | T{ : SSQ3 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T 1790 | T{ : SSQ4 S\" \nOne line...\nanotherLine\n" type ; -> }T 1791 | T{ : SSQ5 S\" abeflmnqrtvxz" S" abeflmnqrtvxz" S= ; -> }T 1792 | T{ : SSQ6 S\" a\""2DROP 1111 ; -> }T \ Parsing behaviour 1793 | 1794 | : test.s\" 1795 | ." TESTING S\" '"' emit ." (Forth 2012 compilation mode)" cr 1796 | \ Extended the Forth 200X RfD tests 1797 | \ Note this tests the Core Ext definition of S\" which has unedfined 1798 | \ interpretation semantics. S\" in interpretation mode is tested in the tests on 1799 | \ the File-Access word set 1800 | 1801 | T{ SSQ1 -> TRUE }T 1802 | T{ SSQ2 SWAP DROP -> 0 }T \ Empty string 1803 | 1804 | T{ SSQ3 SWAP DROP -> 20 }T \ String length 1805 | T{ SSQ3 DROP C@ -> 7 }T \ \a BEL Bell 1806 | T{ SSQ3 DROP 1 CHARS + C@ -> 8 }T \ \b BS Backspace 1807 | T{ SSQ3 DROP 2 CHARS + C@ -> 27 }T \ \e ESC Escape 1808 | T{ SSQ3 DROP 3 CHARS + C@ -> 12 }T \ \f FF Form feed 1809 | T{ SSQ3 DROP 4 CHARS + C@ -> 10 }T \ \l LF Line feed 1810 | T{ SSQ3 DROP 5 CHARS + C@ -> 13 }T \ \m CR of CR/LF pair 1811 | T{ SSQ3 DROP 6 CHARS + C@ -> 10 }T \ LF of CR/LF pair 1812 | T{ SSQ3 DROP 7 CHARS + C@ -> 34 }T \ \q " Double Quote 1813 | T{ SSQ3 DROP 8 CHARS + C@ -> 13 }T \ \r CR Carriage Return 1814 | T{ SSQ3 DROP 9 CHARS + C@ -> 9 }T \ \t TAB Horizontal Tab 1815 | T{ SSQ3 DROP 10 CHARS + C@ -> 11 }T \ \v VT Vertical Tab 1816 | T{ SSQ3 DROP 11 CHARS + C@ -> 15 }T \ \x0F Given Char 1817 | T{ SSQ3 DROP 12 CHARS + C@ -> 48 }T \ 0 0 Digit follow on 1818 | T{ SSQ3 DROP 13 CHARS + C@ -> 31 }T \ \x1F Given Char 1819 | T{ SSQ3 DROP 14 CHARS + C@ -> 'a' }T \ a a Hex follow on 1820 | T{ SSQ3 DROP 15 CHARS + C@ -> 171 }T \ \xaB Insensitive Given Char 1821 | T{ SSQ3 DROP 16 CHARS + C@ -> 'x' }T \ x x Non hex follow on 1822 | T{ SSQ3 DROP 17 CHARS + C@ -> 0 }T \ \z NUL No Character 1823 | T{ SSQ3 DROP 18 CHARS + C@ -> 34 }T \ \" " Double Quote 1824 | T{ SSQ3 DROP 19 CHARS + C@ -> 92 }T \ \\ \ Back Slash 1825 | 1826 | \ The above does not test \n as this is a system dependent value. 1827 | \ Check it displays a new line 1828 | CR ." The next test should display:" 1829 | CR ." One line..." 1830 | CR ." another line" 1831 | T{ SSQ4 -> }T 1832 | 1833 | \ Test bare escapable characters appear as themselves 1834 | T{ SSQ5 -> TRUE }T 1835 | 1836 | T{ SSQ6 -> 1111 }T \ Parsing behaviour 1837 | 1838 | \ T{ : SSQ7 S\" 111 : SSQ8 s\\\" 222\" EVALUATE ; SSQ8 333" EVALUATE ; -> }T 1839 | \ T{ SSQ7 -> 111 222 333 }T 1840 | \ T{ : SSQ9 S\" 11 : SSQ10 s\\\" \\x32\\x32\" EVALUATE ; SSQ10 33" EVALUATE ; -> }T 1841 | \ T{ SSQ9 -> 11 22 33 }T 1842 | ; 1843 | 1844 | \ ----- 1845 | 1846 | : target-test 1847 | #23 #53272 c! \ switch to upper/lower case mode 1848 | test-basic-assumptions 1849 | test-booleans 1850 | test-shift 1851 | test-comparisons 1852 | test-stack-ops 1853 | test-return-stack-ops 1854 | test-add-subtract 1855 | test-multiply 1856 | test-divide 1857 | test-here 1858 | test-char 1859 | test-tick 1860 | test-control 1861 | test-loop 1862 | test-defines 1863 | test-format 1864 | test-fill-move 1865 | OUTPUT-TEST 1866 | ACCEPT-TEST 1867 | CR ." End of Core word set tests" CR 1868 | 1869 | test+doloop1 1870 | test+doloop-largesmall 1871 | test+doloop-maxmin 1872 | test+do+loop 1873 | test+multirecurse 1874 | test+melse 1875 | test+immediate 1876 | test+immediate-toggle 1877 | test+parse 1878 | test+number-prefixes 1879 | test+definition-names 1880 | test+if-begin-repeat 1881 | test+does> 1882 | CR ." End of additional Core tests" CR 1883 | 1884 | test.true-false 1885 | test.<>u> 1886 | test.0<>0> 1887 | test.niptuckrollpick 1888 | test.2>r2r@2r> 1889 | test.hex 1890 | test.within 1891 | test.again 1892 | test.?do 1893 | test.buffer: 1894 | test.value-to 1895 | test.caseof 1896 | test.noname-recurse 1897 | test.cquote 1898 | test.compile, 1899 | test.ru.r 1900 | test.pad-erase 1901 | test.defer 1902 | test.holds 1903 | test.s\" 1904 | CR ." End of Core Extension word tests" CR ; 1905 | 1906 | compile target-test 1907 | --------------------------------------------------------------------------------