mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-06-27 14:29:33 +00:00
9a568b3a03
Names are adapted to DOS 8.3 file names, PETSCII adaptions of core.fth are reverted (DOS uses ASCII), the input test is disabled, since no way was yet found to inject keystrokes into dosbox. And some tweaks were applied to ans-shim.fth and the golden files to make the first tests (preliminary & core) to pass.
144 lines
4.7 KiB
Forth
144 lines
4.7 KiB
Forth
( The ANS/Forth 2012 test suite is being modified so that the test programs )
|
|
( for the optional word sets only use standard words from the Core word set. )
|
|
( This file, which is included *after* the Core test programs, contains )
|
|
( various definitions for use by the optional word set test programs to )
|
|
( remove any dependencies between word sets. )
|
|
|
|
DECIMAL
|
|
|
|
( First a definition to see if a word is already defined. Note that )
|
|
( [DEFINED] [IF] [ELSE] and [THEN] are in the optional Programming Tools )
|
|
( word set. )
|
|
|
|
VARIABLE (\?) 0 (\?) ! ( Flag: Word defined = 0 | word undefined = -1 )
|
|
|
|
( [?DEF] followed by [?IF] cannot be used again until after [THEN] )
|
|
: [?DEF] ( "name" -- )
|
|
BL WORD FIND SWAP DROP 0= (\?) !
|
|
;
|
|
|
|
\ Test [?DEF]
|
|
T{ 0 (\?) ! [?DEF] ?DEFTEST1 (\?) @ -> -1 }T
|
|
: ?DEFTEST1 1 ;
|
|
T{ -1 (\?) ! [?DEF] ?DEFTEST1 (\?) @ -> 0 }T
|
|
|
|
: [?UNDEF] [?DEF] (\?) @ 0= (\?) ! ;
|
|
|
|
\ Equivalents of [IF] [ELSE] [THEN], these must not be nested
|
|
: [?IF] ( f -- ) (\?) ! ; IMMEDIATE
|
|
: [?ELSE] ( -- ) (\?) @ 0= (\?) ! ; IMMEDIATE
|
|
: [?THEN] ( -- ) 0 (\?) ! ; IMMEDIATE
|
|
|
|
( A conditional comment and \ will be defined. Note that these definitions )
|
|
( are inadequate for use in Forth blocks. If needed in the blocks test )
|
|
( program they will need to be modified here or redefined there )
|
|
|
|
( \? is a conditional comment )
|
|
: \? ( "..." -- ) (\?) @ IF EXIT THEN SOURCE >IN ! DROP ; IMMEDIATE
|
|
|
|
\ Test \?
|
|
T{ [?DEF] ?DEFTEST1 \? : ?DEFTEST1 2 ; \ Should not be redefined
|
|
?DEFTEST1 -> 1 }T
|
|
T{ [?DEF] ?DEFTEST2 \? : ?DEFTEST1 2 ; \ Should be redefined
|
|
?DEFTEST1 -> 2 }T
|
|
|
|
[?DEF] TRUE \? -1 CONSTANT TRUE
|
|
[?DEF] FALSE \? 0 CONSTANT FALSE
|
|
[?DEF] NIP \? : NIP SWAP DROP ;
|
|
[?DEF] TUCK \? : TUCK SWAP OVER ;
|
|
|
|
[?DEF] PARSE
|
|
\? : BUMP ( caddr u n -- caddr+n u-n )
|
|
\? TUCK - >R CHARS + R>
|
|
\? ;
|
|
|
|
\? : PARSE ( ch "ccc<ch>" -- caddr u )
|
|
\? >R SOURCE >IN @ BUMP
|
|
\? OVER R> SWAP >R >R ( -- start u1 ) ( R: -- start ch )
|
|
\? BEGIN
|
|
\? DUP
|
|
\? WHILE
|
|
\? OVER C@ R@ = 0=
|
|
\? WHILE
|
|
\? 1 BUMP
|
|
\? REPEAT
|
|
\? 1- ( end u2 ) \ delimiter found
|
|
\? THEN
|
|
\? SOURCE NIP SWAP - >IN ! ( -- end )
|
|
\? R> DROP R> ( -- end start )
|
|
\? TUCK - 1 CHARS / ( -- start u )
|
|
\? ;
|
|
|
|
[?DEF] .( \? : .( [CHAR] ) PARSE TYPE ; IMMEDIATE
|
|
|
|
\ S= to compare (case sensitive) two strings to avoid use of COMPARE from
|
|
\ the String word set. It is defined in core.fr and conditionally defined
|
|
\ here if core.fr has not been included by the user
|
|
|
|
[?DEF] S=
|
|
\? : S= ( caddr1 u1 caddr2 u2 -- f ) \ f = TRUE if strings are equal
|
|
\? ROT OVER = 0= IF DROP 2DROP FALSE EXIT THEN
|
|
\? DUP 0= IF DROP 2DROP TRUE EXIT THEN
|
|
\? 0 DO
|
|
\? OVER C@ OVER C@ = 0= IF 2DROP FALSE UNLOOP EXIT THEN
|
|
\? CHAR+ SWAP CHAR+
|
|
\? LOOP 2DROP TRUE
|
|
\? ;
|
|
|
|
\ Buffer for strings in interpretive mode since S" only valid in compilation
|
|
\ mode when File-Access word set is defined
|
|
|
|
64 CONSTANT SBUF-SIZE
|
|
CREATE SBUF1 SBUF-SIZE CHARS ALLOT
|
|
CREATE SBUF2 SBUF-SIZE CHARS ALLOT
|
|
|
|
\ ($") saves a counted string at (caddr)
|
|
: ($") ( caddr "ccc" -- caddr' u )
|
|
[CHAR] " PARSE ROT 2DUP C! ( -- ca2 u2 ca)
|
|
CHAR+ SWAP 2DUP 2>R CHARS MOVE ( -- ) ( R: -- ca' u2 )
|
|
2R>
|
|
;
|
|
|
|
: $" ( "ccc" -- caddr u ) SBUF1 ($") ;
|
|
: $2" ( "ccc" -- caddr u ) SBUF2 ($") ;
|
|
: $CLEAR ( caddr -- ) SBUF-SIZE BL FILL ;
|
|
: CLEAR-SBUFS ( -- ) SBUF1 $CLEAR SBUF2 $CLEAR ;
|
|
|
|
\ More definitions in core.fr used in other test programs, conditionally
|
|
\ defined here if core.fr has not been loaded
|
|
|
|
[?DEF] MAX-UINT \? 0 INVERT CONSTANT MAX-UINT
|
|
[?DEF] MAX-INT \? 0 INVERT 1 RSHIFT CONSTANT MAX-INT
|
|
[?DEF] MIN-INT \? 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT
|
|
[?DEF] MID-UINT \? 0 INVERT 1 RSHIFT CONSTANT MID-UINT
|
|
[?DEF] MID-UINT+1 \? 0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1
|
|
|
|
[?DEF] 2CONSTANT \? : 2CONSTANT CREATE , , DOES> 2@ ;
|
|
|
|
BASE @ 2 BASE ! -1 0 <# #S #> SWAP DROP CONSTANT BITS/CELL BASE !
|
|
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
\ Tests
|
|
|
|
: STR1 S" abcd" ; : STR2 S" abcde" ;
|
|
: STR3 S" abCd" ; : STR4 S" wbcd" ;
|
|
: S"" S" " ;
|
|
|
|
T{ STR1 2DUP S= -> TRUE }T
|
|
T{ STR2 2DUP S= -> TRUE }T
|
|
T{ S"" 2DUP S= -> TRUE }T
|
|
T{ STR1 STR2 S= -> FALSE }T
|
|
T{ STR1 STR3 S= -> FALSE }T
|
|
T{ STR1 STR4 S= -> FALSE }T
|
|
|
|
T{ CLEAR-SBUFS -> }T
|
|
T{ $" abcdefghijklm" SBUF1 COUNT S= -> TRUE }T
|
|
T{ $" nopqrstuvwxyz" SBUF2 OVER S= -> FALSE }T
|
|
T{ $2" abcdefghijklm" SBUF1 COUNT S= -> FALSE }T
|
|
T{ $2" nopqrstuvwxyz" SBUF1 COUNT S= -> TRUE }T
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
|
|
CR $" Test utilities loaded" TYPE CR
|