-; -------------------------------------
-; CORETEST.4TH for any FastForth target
-; -------------------------------------
+\ ; -------------------------------------
+\ ; CORETEST.4TH for any FastForth target
+\ ; -------------------------------------
+
+[DEFINED] {CORETEST} [IF] {CORETEST} [THEN]
+
+MARKER {CORETEST}
: ABORT_TEST
$0D EMIT \ return to column 1
+POSTPONE {CORETEST} \ that remove all test words
ABORT" {CORE_ANS} word set not found !"
;
-[UNDEFINED] {CORE_ANS}
-ABORT_TEST
+[UNDEFINED] {CORE_ANS} ABORT_TEST
: CORETESTSUCCESS
$0A BASE !
$0D EMIT \ return to column 1
-1 ABORT" CORE tests success!" \ that remove all test words
+{CORETEST} \ that remove all test words
+1 ABORT" CORE tests success!"
;
\ From: John Hayes S1I
T{ 1STA 1+ -> 2NDA }T \ ... BY ONE ADDRESS UNIT
( MISSING TEST: NEGATIVE ALLOT )
+\ Added by GWJ so that ALIGN can be used before , (comma) is tested
+1 ALIGNED CONSTANT ALMNT \ -- 1|2|4|8 for 8|16|32|64 bit alignment
+ALIGN
+T{ HERE 1 ALLOT ALIGN HERE SWAP - ALMNT = -> <TRUE> }T
+\ End of extra test
+
HERE 1 ,
HERE 2 ,
CONSTANT 2ND
T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T
T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T
T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T
-T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T \ SHOULD FAIL TO CONVERT THESE
+\ FOLLOWING SHOULD FAIL TO CONVERT
+T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T
T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T
T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T
T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T
T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T
-: GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
+: GN1 \ ( UD BASE -- UD' LEN )
+\ UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
BASE @ >R BASE !
<# #S #>
0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY
[THEN]
[DEFINED] :NONAME [IF]
+
+[UNDEFINED] CASE [IF]
+\ https://forth-standard.org/standard/core/CASE
+: CASE 0 ; IMMEDIATE \ -- #of-1
+
+\ https://forth-standard.org/standard/core/OF
+: OF \ #of-1 -- orgOF #of
+1+ \ count OFs
+>R \ move off the stack in case the control-flow stack is the data stack.
+POSTPONE OVER POSTPONE = \ copy and test case value
+POSTPONE IF \ add orig to control flow stack
+POSTPONE DROP \ discards case value if =
+R> \ we can bring count back now
+; IMMEDIATE
+
+\ https://forth-standard.org/standard/core/ENDOF
+: ENDOF \ orgOF #of -- orgENDOF #of
+>R \ move off the stack in case the control-flow stack is the data stack.
+POSTPONE ELSE
+R> \ we can bring count back now
+; IMMEDIATE
+
+\ https://forth-standard.org/standard/core/ENDCASE
+: ENDCASE \ orgENDOF1..orgENDOFn #of --
+POSTPONE DROP
+0 DO
+ POSTPONE THEN
+LOOP
+; IMMEDIATE
+[THEN]
+
VARIABLE nn1
VARIABLE nn2
T{ :NONAME 1234 ; nn1 ! -> }T
T{ :NONAME 9876 ; nn2 ! -> }T
T{ nn1 @ EXECUTE -> 1234 }T
T{ nn2 @ EXECUTE -> 9876 }T
+
+T{ :NONAME ( n -- 0,1,..n ) DUP IF DUP >R 1- RECURSE R> THEN ;
+ CONSTANT RN1 -> }T
+T{ 0 RN1 EXECUTE -> 0 }T
+T{ 4 RN1 EXECUTE -> 0 1 2 3 4 }T
+
+:NONAME ( n -- n1 ) \ Multiple RECURSEs in one definition
+ 1- DUP
+ CASE 0 OF EXIT ENDOF
+ 1 OF 11 SWAP RECURSE ENDOF
+ 2 OF 22 SWAP RECURSE ENDOF
+ 3 OF 33 SWAP RECURSE ENDOF
+ DROP ABS RECURSE EXIT
+ ENDCASE
+; CONSTANT RN2
+
+T{ 1 RN2 EXECUTE -> 0 }T
+T{ 2 RN2 EXECUTE -> 11 0 }T
+T{ 4 RN2 EXECUTE -> 33 22 11 0 }T
+T{ 25 RN2 EXECUTE -> 33 22 11 0 }T
+
[THEN]
[DEFINED] IS [IF]
T{ 1 2 defer5 -> 3 }T
[THEN]
+\ ==============================================================================
+\ COREPLUSTEST
+\ ==============================================================================
+\ Additional tests on the the ANS Forth Core word set
+\ ------------------------------------------------------------------------------
+\ https://raw.githubusercontent.com/gerryjackson/forth2012-test-suite/master/src/coreplustest.fth
+
+\ This program was written by Gerry Jackson in 2007, with contributions from
+\ others where indicated, and is in the public domain - it can be distributed
+\ and/or modified in any way but please retain this notice.
+
+\ This program is distributed in the hope that it will be useful,
+\ but WITHOUT ANY WARRANTY; without even the implied warranty of
+\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+\ The tests are not claimed to be comprehensive or correct
+
+\ ------------------------------------------------------------------------------
+\ The tests are based on John Hayes test program for the core word set
+\
+\ This file provides some more tests on Core words where the original Hayes
+\ tests are thought to be incomplete
+\
+\ Words tested in this file are:
+\ DO I +LOOP RECURSE ELSE >IN IMMEDIATE FIND IF...BEGIN...REPEAT ALLOT DOES>
+\ and
+\ Parsing behaviour
+\ Number prefixes # $ % and 'A' character input
+\ Definition names
+\ ------------------------------------------------------------------------------
+\ Assumptions and dependencies:
+\ - tester.fr or ttester.fs has been loaded prior to this file
+\ - core.fr has been loaded so that constants <TRUE> MAX-INT, MIN-INT and
+\ MAX-UINT are defined
+\ ------------------------------------------------------------------------------
+
+DECIMAL
+
+TESTING DO +LOOP with run-time increment, negative increment, infinite loop
+\ Contributed by Reinhold Straub
+
+VARIABLE ITERATIONS
+VARIABLE INCREMENT
+: GD7 ( LIMIT START INCREMENT -- )
+ INCREMENT !
+ 0 ITERATIONS !
+ DO
+ 1 ITERATIONS +!
+ I
+ ITERATIONS @ 6 = IF LEAVE THEN
+ INCREMENT @
+ +LOOP ITERATIONS @
+;
+
+T{ 4 4 -1 GD7 -> 4 1 }T
+T{ 1 4 -1 GD7 -> 4 3 2 1 4 }T
+T{ 4 1 -1 GD7 -> 1 0 -1 -2 -3 -4 6 }T
+T{ 4 1 0 GD7 -> 1 1 1 1 1 1 6 }T
+T{ 0 0 0 GD7 -> 0 0 0 0 0 0 6 }T
+T{ 1 4 0 GD7 -> 4 4 4 4 4 4 6 }T
+T{ 1 4 1 GD7 -> 4 5 6 7 8 9 6 }T
+T{ 4 1 1 GD7 -> 1 2 3 3 }T
+T{ 4 4 1 GD7 -> 4 5 6 7 8 9 6 }T
+T{ 2 -1 -1 GD7 -> -1 -2 -3 -4 -5 -6 6 }T
+T{ -1 2 -1 GD7 -> 2 1 0 -1 4 }T
+T{ 2 -1 0 GD7 -> -1 -1 -1 -1 -1 -1 6 }T
+T{ -1 2 0 GD7 -> 2 2 2 2 2 2 6 }T
+T{ -1 2 1 GD7 -> 2 3 4 5 6 7 6 }T
+T{ 2 -1 1 GD7 -> -1 0 1 3 }T
+T{ -20 30 -10 GD7 -> 30 20 10 0 -10 -20 6 }T
+T{ -20 31 -10 GD7 -> 31 21 11 1 -9 -19 6 }T
+T{ -20 29 -10 GD7 -> 29 19 9 -1 -11 5 }T
+
+\ ------------------------------------------------------------------------------
+TESTING DO +LOOP with large and small increments
+
+\ Contributed by Andrew Haley
+
+MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP
+USTEP NEGATE CONSTANT -USTEP
+MAX-INT 7 RSHIFT 1+ CONSTANT STEP
+STEP NEGATE CONSTANT -STEP
+
+VARIABLE BUMP
+
+T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; -> }T
+
+T{ 0 MAX-UINT 0 USTEP GD8 -> 256 }T
+T{ 0 0 MAX-UINT -USTEP GD8 -> 256 }T
+
+T{ 0 MAX-INT MIN-INT STEP GD8 -> 256 }T
+T{ 0 MIN-INT MAX-INT -STEP GD8 -> 256 }T
+
+\ Two's complement arithmetic, wraps around modulo wordsize
+\ Only tested if the Forth system does wrap around, use of conditional
+\ compilation deliberately avoided
+
+MAX-INT 1+ MIN-INT = CONSTANT +WRAP?
+MIN-INT 1- MAX-INT = CONSTANT -WRAP?
+MAX-UINT 1+ 0= CONSTANT +UWRAP?
+0 1- MAX-UINT = CONSTANT -UWRAP?
+
+: GD9 ( n limit start step f result -- )
+ >R IF GD8 ELSE 2DROP 2DROP R@ THEN -> R> }T
+;
+
+T{ 0 0 0 USTEP +UWRAP? 256 GD9
+T{ 0 0 0 -USTEP -UWRAP? 1 GD9
+T{ 0 MIN-INT MAX-INT STEP +WRAP? 1 GD9
+T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9
+
+\ ------------------------------------------------------------------------------
+TESTING DO +LOOP with maximum and minimum increments
+
+: (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ;
+(-MI) CONSTANT -MAX-INT
+
+T{ 0 1 0 MAX-INT GD8 -> 1 }T
+T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8 -> 2 }T
+
+T{ 0 MAX-INT 0 MAX-INT GD8 -> 1 }T
+T{ 0 MAX-INT 1 MAX-INT GD8 -> 1 }T
+T{ 0 MAX-INT -1 MAX-INT GD8 -> 2 }T
+T{ 0 MAX-INT DUP 1- MAX-INT GD8 -> 1 }T
+
+T{ 0 MIN-INT 1+ 0 MIN-INT GD8 -> 1 }T
+T{ 0 MIN-INT 1+ -1 MIN-INT GD8 -> 1 }T
+T{ 0 MIN-INT 1+ 1 MIN-INT GD8 -> 2 }T
+T{ 0 MIN-INT 1+ DUP MIN-INT GD8 -> 1 }T
+
+\ ------------------------------------------------------------------------------
+\ TESTING +LOOP setting I to an arbitrary value
+
+\ The specification for +LOOP permits the loop index I to be set to any value
+\ including a value outside the range given to the corresponding DO.
+
+\ SET-I is a helper to set I in a DO ... +LOOP to a given value
+\ n2 is the value of I in a DO ... +LOOP
+\ n3 is a test value
+\ If n2=n3 then return n1-n2 else return 1
+: SET-I ( n1 n2 n3 -- n1-n2 | 1 )
+ OVER = IF - ELSE 2DROP 1 THEN
+;
+
+: -SET-I ( n1 n2 n3 -- n1-n2 | -1 )
+ SET-I DUP 1 = IF NEGATE THEN
+;
+
+: PL1 20 1 DO I 18 I 3 SET-I +LOOP ;
+T{ PL1 -> 1 2 3 18 19 }T
+: PL2 20 1 DO I 20 I 2 SET-I +LOOP ;
+T{ PL2 -> 1 2 }T
+: PL3 20 5 DO I 19 I 2 SET-I DUP 1 = IF DROP 0 I 6 SET-I THEN +LOOP ;
+T{ PL3 -> 5 6 0 1 2 19 }T
+: PL4 20 1 DO I MAX-INT I 4 SET-I +LOOP ;
+T{ PL4 -> 1 2 3 4 }T
+: PL5 -20 -1 DO I -19 I -3 -SET-I +LOOP ;
+T{ PL5 -> -1 -2 -3 -19 -20 }T
+: PL6 -20 -1 DO I -21 I -4 -SET-I +LOOP ;
+T{ PL6 -> -1 -2 -3 -4 }T
+: PL7 -20 -1 DO I MIN-INT I -5 -SET-I +LOOP ;
+T{ PL7 -> -1 -2 -3 -4 -5 }T
+: PL8 -20 -5 DO I -20 I -2 -SET-I DUP -1 = IF DROP 0 I -6 -SET-I THEN +LOOP ;
+T{ PL8 -> -5 -6 0 -1 -2 -20 }T
+
+\ ------------------------------------------------------------------------------
+TESTING multiple RECURSEs in one colon definition
+
+: ACK ( m n -- u ) \ Ackermann function, from Rosetta Code
+ OVER 0= IF NIP 1+ EXIT THEN \ ack(0, n) = n+1
+ SWAP 1- SWAP ( -- m-1 n )
+ DUP 0= IF 1+ RECURSE EXIT THEN \ ack(m, 0) = ack(m-1, 1)
+ 1- OVER 1+ SWAP RECURSE RECURSE \ ack(m, n) = ack(m-1, ack(m,n-1))
+;
+
+T{ 0 0 ACK -> 1 }T
+T{ 3 0 ACK -> 5 }T
+T{ 2 4 ACK -> 11 }T
+
+\ ------------------------------------------------------------------------------
+TESTING multiple ELSE's in an IF statement
+\ Discussed on comp.lang.forth and accepted as valid ANS Forth
+
+: MELSE IF 1 ELSE 2 ELSE 3 ELSE 4 ELSE 5 THEN ;
+T{ 0 MELSE -> 2 4 }T
+T{ -1 MELSE -> 1 3 5 }T
+
+\ ------------------------------------------------------------------------------
+TESTING manipulation of >IN in interpreter mode
+
+T{ 12345 DEPTH OVER 9 < 34 AND + 3 + >IN ! -> 12345 2345 345 45 5 }T
+T{ 14145 8115 ?DUP 0= 34 AND >IN +! TUCK MOD 14 >IN ! GCD CALCULATION -> 15 }T
+
+\ ------------------------------------------------------------------------------
+TESTING IMMEDIATE with CONSTANT VARIABLE and CREATE [ ... DOES> ]
+
+T{ 123 CONSTANT IW1 IMMEDIATE IW1 -> 123 }T
+T{ : IW2 IW1 LITERAL ; IW2 -> 123 }T
+T{ VARIABLE IW3 IMMEDIATE 234 IW3 ! IW3 @ -> 234 }T
+T{ : IW4 IW3 [ @ ] LITERAL ; IW4 -> 234 }T
+\ T{ :NONAME [ 345 ] IW3 [ ! ] ; DROP IW3 @ -> 345 }T
+T{ CREATE IW5 456 , IMMEDIATE -> }T
+\ T{ :NONAME IW5 [ @ IW3 ! ] ; DROP IW3 @ -> 456 }T
+T{ : IW6 CREATE , IMMEDIATE DOES> @ 1+ ; -> }T
+T{ 111 IW6 IW7 IW7 -> 112 }T
+T{ : IW8 IW7 LITERAL 1+ ; IW8 -> 113 }T
+T{ : IW9 CREATE , DOES> @ 2 + IMMEDIATE ; -> }T
+: FIND-IW BL WORD FIND NIP ; ( -- 0 | 1 | -1 )
+T{ 222 IW9 IW10 FIND-IW IW10 -> -1 }T \ IW10 is not immediate
+T{ IW10 FIND-IW IW10 -> 224 1 }T \ IW10 becomes immediate
+
+[DEFINED] :NONAME [IF]
+T{ :NONAME [ 345 ] IW3 [ ! ] ; DROP IW3 @ -> 345 }T
+T{ :NONAME IW5 [ @ IW3 ! ] ; DROP IW3 @ -> 456 }T
+[THEN]
+
+\ ------------------------------------------------------------------------------
+TESTING that IMMEDIATE doesn't toggle a flag
+
+VARIABLE IT1 0 IT1 !
+: IT2 1234 IT1 ! ; IMMEDIATE IMMEDIATE
+T{ : IT3 IT2 ; IT1 @ -> 1234 }T
+
+\ ------------------------------------------------------------------------------
+TESTING parsing behaviour of S" ." and (
+\ which should parse to just beyond the terminating character no space needed
+
+T{ : GC5 S" A string"2DROP ; GC5 -> }T
+T{ ( A comment)1234 -> 1234 }T
+T{ : PB1 CR ." You should see 2345: "." 2345"( A comment) CR ; PB1 -> }T
+
+\ ------------------------------------------------------------------------------
+TESTING number prefixes # $ % and 'c' character input
+\ Adapted from the Forth 200X Draft 14.5 document
+
+VARIABLE OLD-BASE
+DECIMAL BASE @ OLD-BASE !
+T{ #1289 -> 1289 }T
+T{ #-1289 -> -1289 }T
+T{ $12eF -> 4847 }T
+T{ $-12eF -> -4847 }T
+T{ %10010110 -> 150 }T
+T{ %-10010110 -> -150 }T
+T{ 'z' -> 122 }T
+T{ 'Z' -> 90 }T
+\ Check BASE is unchanged
+T{ BASE @ OLD-BASE @ = -> <TRUE> }T
+
+\ Repeat in Hex mode
+16 OLD-BASE ! 16 BASE !
+T{ #1289 -> 509 }T
+T{ #-1289 -> -509 }T
+T{ $12eF -> 12EF }T
+T{ $-12eF -> -12EF }T
+T{ %10010110 -> 96 }T
+T{ %-10010110 -> -96 }T
+T{ 'z' -> 7a }T
+T{ 'Z' -> 5a }T
+\ Check BASE is unchanged
+T{ BASE @ OLD-BASE @ = -> <TRUE> }T \ 2
+
+DECIMAL
+\ Check number prefixes in compile mode
+T{ : nmp #8327 $-2cbe %011010111 ''' ; nmp -> 8327 -11454 215 39 }T
+
+\ ------------------------------------------------------------------------------
+TESTING definition names
+\ should support {1..31} graphical characters
+: !"#$%&'()*+,-./0123456789:;<=>? 1 ;
+T{ !"#$%&'()*+,-./0123456789:;<=>? -> 1 }T
+: @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ 2 ;
+T{ @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ -> 2 }T
+: _`abcdefghijklmnopqrstuvwxyz{|} 3 ;
+T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T
+: _`abcdefghijklmnopqrstuvwxyz{|~ 4 ; \ Last character different
+T{ _`abcdefghijklmnopqrstuvwxyz{|~ -> 4 }T
+T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T
+
+\ ------------------------------------------------------------------------------
+TESTING FIND with a zero length string and a non-existent word
+
+CREATE EMPTYSTRING 0 C,
+: EMPTYSTRING-FIND-CHECK ( c-addr 0 | xt 1 | xt -1 -- t|f )
+ DUP IF ." FIND returns a TRUE value for an empty string!" CR THEN
+ 0= SWAP EMPTYSTRING = = ;
+T{ EMPTYSTRING FIND EMPTYSTRING-FIND-CHECK -> <TRUE> }T
+
+CREATE NON-EXISTENT-WORD \ Same as in exceptiontest.fth
+ 15 C, CHAR $ C, CHAR $ C, CHAR Q C, CHAR W C, CHAR E C, CHAR Q C,
+ CHAR W C, CHAR E C, CHAR Q C, CHAR W C, CHAR E C, CHAR R C, CHAR T C,
+ CHAR $ C, CHAR $ C,
+T{ NON-EXISTENT-WORD FIND -> NON-EXISTENT-WORD 0 }T
+
+\ ------------------------------------------------------------------------------
+TESTING IF ... BEGIN ... REPEAT (unstructured)
+
+T{ : UNS1 DUP 0 > IF 9 SWAP BEGIN 1+ DUP 3 > IF EXIT THEN REPEAT ; -> }T
+T{ -6 UNS1 -> -6 }T
+T{ 1 UNS1 -> 9 4 }T
+
+\ ------------------------------------------------------------------------------
+TESTING DOES> doesn't cause a problem with a CREATEd address
+
+: MAKE-2CONST DOES> 2@ ;
+T{ CREATE 2K 3 , 2K , MAKE-2CONST 2K -> ' 2K >BODY 3 }T
+
+\ ------------------------------------------------------------------------------
+TESTING ALLOT ( n -- ) where n <= 0
+
+T{ HERE 5 ALLOT -5 ALLOT HERE = -> <TRUE> }T
+T{ HERE 0 ALLOT HERE = -> <TRUE> }T
+
+\ -----------------------------------------------------------------------------
+TESTING MARKER (contributed by James Bowman)
+
+[DEFINED] MARKER [IF]
+
+ [UNDEFINED] 0<> [IF]
+ CODE 0<>
+ CMP #0,R14
+ 0<> IF MOV #-1,R14 THEN
+ MOV @R13+,R0
+ ENDCODE
+ [THEN]
+
+T{ : MA? BL WORD FIND NIP 0<> ; -> }T
+T{ MARKER MA0 -> }T
+T{ : MA1 111 ; -> }T
+T{ MARKER MA2 -> }T
+T{ : MA1 222 ; -> }T
+T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE TRUE }T
+T{ MA1 MA2 MA1 -> 222 111 }T
+T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE FALSE }T
+T{ MA0 -> }T
+T{ MA? MA0 MA? MA1 MA? MA2 -> FALSE FALSE FALSE }T
+
+[THEN]
+
+
CR .( End of Core word set tests)
CORETESTSUCCESS
OSDN Git Service
