diff --git a/runtests.fs b/runtests.fs index e6aa3ff..9f5f7af 100644 --- a/runtests.fs +++ b/runtests.fs @@ -8,6 +8,8 @@ include test/tester.fs include test/core.fs -include test/coreplustest.fs +include test/errorreport.fs +include test/coreexttest.fs +report-errors report-and-exit diff --git a/test/coreexttest.fs b/test/coreexttest.fs new file mode 100644 index 0000000..b6d5429 --- /dev/null +++ b/test/coreexttest.fs @@ -0,0 +1,691 @@ +\ planckforth - +\ Copyright (C) 2021 nineties + +\ test/tester.fs and test codes are base on +\ https://github.com/gerryjackson/forth2012-test-suite + +testing Core Extension words + +decimal + +testing true false + +T{ true -> 1 }T +T{ false -> 0 }T + +\ ----------------------------------------------------------------------------- +testing <> u> (contributed by James Bowman) + +T{ 0 0 <> -> false }T +T{ 1 1 <> -> false }T +T{ -1 -1 <> -> false }T +T{ 1 0 <> -> true }T +T{ -1 0 <> -> true }T +T{ 0 1 <> -> true }T +T{ 0 -1 <> -> true }T + +T{ 0 1 u> -> false }T +T{ 1 2 u> -> false }T +T{ 0 mid-uint u> -> false }T +T{ 0 max-uint u> -> false }T +T{ mid-uint max-uint u> -> false }T +T{ 0 0 u> -> false }T +T{ 1 1 u> -> false }T +T{ 1 0 u> -> true }T +T{ 2 1 u> -> true }T +T{ mid-uint 0 u> -> true }T +T{ max-uint 0 u> -> true }T +T{ max-uint mid-uint u> -> true }T + +\ ----------------------------------------------------------------------------- +testing 0<> 0> (contributed by James Bowman) + +T{ 0 0<> -> false }T +T{ 1 0<> -> true }T +T{ 2 0<> -> true }T +T{ -1 0<> -> true }T +T{ max-uint 0<> -> true }T +T{ min-int 0<> -> true }T +T{ max-int 0<> -> true }T + +T{ 0 0> -> false }T +T{ -1 0> -> false }T +T{ min-int 0> -> false }T +T{ 1 0> -> true }T +T{ max-int 0> -> true }T + +\ ----------------------------------------------------------------------------- +testing nip tuck roll pick (contributed by James Bowman) + +T{ 1 2 nip -> 2 }T +T{ 1 2 3 nip -> 1 3 }T + +T{ 1 2 tuck -> 2 1 2 }T +T{ 1 2 3 tuck -> 1 3 2 3 }T + +T{ : RO5 100 200 300 400 500 ; -> }T +T{ RO5 3 roll -> 100 300 400 500 200 }T +T{ RO5 2 roll -> RO5 rot }T +T{ RO5 1 roll -> RO5 swap }T +T{ RO5 0 roll -> RO5 }T + +T{ RO5 2 pick -> 100 200 300 400 500 300 }T +T{ RO5 1 pick -> RO5 over }T +T{ RO5 0 pick -> RO5 dup }T + +\ ----------------------------------------------------------------------------- +testing 2>r 2r@ 2r> (contributed by James Bowman) + +skip T{ : RR0 2>r 100 r> r> ; -> }T +skip T{ 300 400 RR0 -> 100 400 300 }T +skip T{ 200 300 400 RR0 -> 200 100 400 300 }T + +skip T{ : RR1 2>r 100 2r@ r> r> ; -> }T +skip T{ 300 400 RR1 -> 100 300 400 400 300 }T +skip T{ 200 300 400 RR1 -> 200 100 300 400 400 300 }T +skip +skip T{ : RR2 2>r 100 2r> ; -> }T +skip T{ 300 400 RR2 -> 100 300 400 }T +skip T{ 200 300 400 RR2 -> 200 100 300 400 }T + +\ ----------------------------------------------------------------------------- +testing hex (contributed by James Bowman) + +T{ base @ hex base @ decimal base @ - swap base ! -> 6 }T + +\ ----------------------------------------------------------------------------- +testing within (contributed by James Bowman) + +T{ 0 0 0 within -> false }T +T{ 0 0 mid-uint within -> true }T +T{ 0 0 mid-uint+1 within -> true }T +T{ 0 0 max-uint within -> true }T +T{ 0 mid-uint 0 within -> false }T +T{ 0 mid-uint mid-uint within -> false }T +T{ 0 mid-uint mid-uint+1 within -> false }T +T{ 0 mid-uint max-uint within -> false }T +T{ 0 mid-uint+1 0 within -> false }T +T{ 0 mid-uint+1 mid-uint within -> true }T +T{ 0 mid-uint+1 mid-uint+1 within -> false }T +T{ 0 mid-uint+1 max-uint within -> false }T +T{ 0 max-uint 0 within -> false }T +T{ 0 max-uint mid-uint within -> true }T +T{ 0 max-uint mid-uint+1 within -> true }T +T{ 0 max-uint max-uint within -> false }T +T{ mid-uint 0 0 within -> false }T +T{ mid-uint 0 mid-uint within -> false }T +T{ mid-uint 0 mid-uint+1 within -> true }T +T{ mid-uint 0 max-uint within -> true }T +T{ mid-uint mid-uint 0 within -> true }T +T{ mid-uint mid-uint mid-uint within -> false }T +T{ mid-uint mid-uint mid-uint+1 within -> true }T +T{ mid-uint mid-uint max-uint within -> true }T +T{ mid-uint mid-uint+1 0 within -> false }T +T{ mid-uint mid-uint+1 mid-uint within -> false }T +T{ mid-uint mid-uint+1 mid-uint+1 within -> false }T +T{ mid-uint mid-uint+1 max-uint within -> false }T +T{ mid-uint max-uint 0 within -> false }T +T{ mid-uint max-uint mid-uint within -> false }T +T{ mid-uint max-uint mid-uint+1 within -> true }T +T{ mid-uint max-uint max-uint within -> false }T +T{ mid-uint+1 0 0 within -> false }T +T{ mid-uint+1 0 mid-uint within -> false }T +T{ mid-uint+1 0 mid-uint+1 within -> false }T +T{ mid-uint+1 0 max-uint within -> true }T +T{ mid-uint+1 mid-uint 0 within -> true }T +T{ mid-uint+1 mid-uint mid-uint within -> false }T +T{ mid-uint+1 mid-uint mid-uint+1 within -> false }T +T{ mid-uint+1 mid-uint max-uint within -> true }T +T{ mid-uint+1 mid-uint+1 0 within -> true }T +T{ mid-uint+1 mid-uint+1 mid-uint within -> true }T +T{ mid-uint+1 mid-uint+1 mid-uint+1 within -> false }T +T{ mid-uint+1 mid-uint+1 max-uint within -> true }T +T{ mid-uint+1 max-uint 0 within -> false }T +T{ mid-uint+1 max-uint mid-uint within -> false }T +T{ mid-uint+1 max-uint mid-uint+1 within -> false }T +T{ mid-uint+1 max-uint max-uint within -> false }T +T{ max-uint 0 0 within -> false }T +T{ max-uint 0 mid-uint within -> false }T +T{ max-uint 0 mid-uint+1 within -> false }T +T{ max-uint 0 max-uint within -> false }T +T{ max-uint mid-uint 0 within -> true }T +T{ max-uint mid-uint mid-uint within -> false }T +T{ max-uint mid-uint mid-uint+1 within -> false }T +T{ max-uint mid-uint max-uint within -> false }T +T{ max-uint mid-uint+1 0 within -> true }T +T{ max-uint mid-uint+1 mid-uint within -> true }T +T{ max-uint mid-uint+1 mid-uint+1 within -> false }T +T{ max-uint mid-uint+1 max-uint within -> false }T +T{ max-uint max-uint 0 within -> true }T +T{ max-uint max-uint mid-uint within -> true }T +T{ max-uint max-uint mid-uint+1 within -> true }T +T{ max-uint max-uint max-uint within -> false }T + +T{ min-int min-int min-int within -> false }T +T{ min-int min-int 0 within -> true }T +T{ min-int min-int 1 within -> true }T +T{ min-int min-int max-int within -> true }T +T{ min-int 0 min-int within -> false }T +T{ min-int 0 0 within -> false }T +T{ min-int 0 1 within -> false }T +T{ min-int 0 max-int within -> false }T +T{ min-int 1 min-int within -> false }T +T{ min-int 1 0 within -> true }T +T{ min-int 1 1 within -> false }T +T{ min-int 1 max-int within -> false }T +T{ min-int max-int min-int within -> false }T +T{ min-int max-int 0 within -> true }T +T{ min-int max-int 1 within -> true }T +T{ min-int max-int max-int within -> false }T +T{ 0 min-int min-int within -> false }T +T{ 0 min-int 0 within -> false }T +T{ 0 min-int 1 within -> true }T +T{ 0 min-int max-int within -> true }T +T{ 0 0 min-int within -> true }T +T{ 0 0 0 within -> false }T +T{ 0 0 1 within -> true }T +T{ 0 0 max-int within -> true }T +T{ 0 1 min-int within -> false }T +T{ 0 1 0 within -> false }T +T{ 0 1 1 within -> false }T +T{ 0 1 max-int within -> false }T +T{ 0 max-int min-int within -> false }T +T{ 0 max-int 0 within -> false }T +T{ 0 max-int 1 within -> true }T +T{ 0 max-int max-int within -> false }T +T{ 1 min-int min-int within -> false }T +T{ 1 min-int 0 within -> false }T +T{ 1 min-int 1 within -> false }T +T{ 1 min-int max-int within -> true }T +T{ 1 0 min-int within -> true }T +T{ 1 0 0 within -> false }T +T{ 1 0 1 within -> false }T +T{ 1 0 max-int within -> true }T +T{ 1 1 min-int within -> true }T +T{ 1 1 0 within -> true }T +T{ 1 1 1 within -> false }T +T{ 1 1 max-int within -> true }T +T{ 1 max-int min-int within -> false }T +T{ 1 max-int 0 within -> false }T +T{ 1 max-int 1 within -> false }T +T{ 1 max-int max-int within -> false }T +T{ max-int min-int min-int within -> false }T +T{ max-int min-int 0 within -> false }T +T{ max-int min-int 1 within -> false }T +T{ max-int min-int max-int within -> false }T +T{ max-int 0 min-int within -> true }T +T{ max-int 0 0 within -> false }T +T{ max-int 0 1 within -> false }T +T{ max-int 0 max-int within -> false }T +T{ max-int 1 min-int within -> true }T +T{ max-int 1 0 within -> true }T +T{ max-int 1 1 within -> false }T +T{ max-int 1 max-int within -> false }T +T{ max-int max-int min-int within -> true }T +T{ max-int max-int 0 within -> true }T +T{ max-int max-int 1 within -> true }T +T{ max-int max-int max-int within -> false }T + +\ ----------------------------------------------------------------------------- +testing unused (contributed by James Bowman & Peter Knaggs) + +variable unused0 +skip T{ unused drop -> }T +skip T{ align unused unused0 ! 0 , unused CELL+ unused0 @ = -> true }T +skip T{ unused unused0 ! 0 C, unused char+ unused0 @ = -> true }T \ aligned -> unaligned +skip T{ unused unused0 ! 0 C, unused char+ unused0 @ = -> true }T \ unaligned -> ? + +\ ----------------------------------------------------------------------------- +testing again (contributed by James Bowman) + +T{ : AG0 701 begin dup 7 mod 0= if exit then 1+ again ; -> }T +T{ AG0 -> 707 }T + +\ ----------------------------------------------------------------------------- +testing marker (contributed by James Bowman) + +T{ : MA? word throw find 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 + +\ ----------------------------------------------------------------------------- +testing ?do + +: QD ?do i loop ; +T{ 789 789 QD -> }T +T{ -9876 -9876 QD -> }T +T{ 5 0 QD -> 0 1 2 3 4 }T + +: QD1 ?do i 10 +loop ; +T{ 50 1 QD1 -> 1 11 21 31 41 }T +T{ 50 0 QD1 -> 0 10 20 30 40 }T + +: QD2 ?do i 3 > if LEAVE else i then loop ; +T{ 5 -1 QD2 -> -1 0 1 2 3 }T + +: QD3 ?do i 1 +loop ; +T{ 4 4 QD3 -> }T +T{ 4 1 QD3 -> 1 2 3 }T +T{ 2 -1 QD3 -> -1 0 1 }T + +: QD4 ?do i -1 +loop ; +T{ 4 4 QD4 -> }T +T{ 1 4 QD4 -> 4 3 2 1 }T +T{ -1 2 QD4 -> 2 1 0 -1 }T + +: QD5 ?do i -10 +loop ; +T{ 1 50 QD5 -> 50 40 30 20 10 }T +T{ 0 50 QD5 -> 50 40 30 20 10 0 }T +T{ -25 10 QD5 -> 10 0 -10 -20 }T + +variable ITERS +variable INCRMNT + +: QD6 ( limit start increment -- ) + INCRMNT ! + 0 ITERS ! + ?do + 1 ITERS +! + i + ITERS @ 6 = if LEAVE then + INCRMNT @ + +loop ITERS @ +; + +T{ 4 4 -1 QD6 -> 0 }T +T{ 1 4 -1 QD6 -> 4 3 2 1 4 }T +T{ 4 1 -1 QD6 -> 1 0 -1 -2 -3 -4 6 }T +T{ 4 1 0 QD6 -> 1 1 1 1 1 1 6 }T +T{ 0 0 0 QD6 -> 0 }T +T{ 1 4 0 QD6 -> 4 4 4 4 4 4 6 }T +T{ 1 4 1 QD6 -> 4 5 6 7 8 9 6 }T +T{ 4 1 1 QD6 -> 1 2 3 3 }T +T{ 4 4 1 QD6 -> 0 }T +T{ 2 -1 -1 QD6 -> -1 -2 -3 -4 -5 -6 6 }T +T{ -1 2 -1 QD6 -> 2 1 0 -1 4 }T +T{ 2 -1 0 QD6 -> -1 -1 -1 -1 -1 -1 6 }T +T{ -1 2 0 QD6 -> 2 2 2 2 2 2 6 }T +T{ -1 2 1 QD6 -> 2 3 4 5 6 7 6 }T +T{ 2 -1 1 QD6 -> -1 0 1 3 }T + +\ ----------------------------------------------------------------------------- +testing BUFFER: + +T{ 8 BUFFER: BUF:TEST -> }T +T{ BUF:TEST dup ALIGNED = -> true }T +T{ 111 BUF:TEST ! 222 BUF:TEST CELL+ ! -> }T +T{ BUF:TEST @ BUF:TEST CELL+ @ -> 111 222 }T + +\ ----------------------------------------------------------------------------- +testing VALUE TO + +T{ 111 VALUE VAL1 -999 VALUE VAL2 -> }T +T{ VAL1 -> 111 }T +T{ VAL2 -> -999 }T +T{ 222 TO VAL1 -> }T +T{ VAL1 -> 222 }T +T{ : VD1 VAL1 ; -> }T +T{ VD1 -> 222 }T +T{ : VD2 TO VAL2 ; -> }T +T{ VAL2 -> -999 }T +T{ -333 VD2 -> }T +T{ VAL2 -> -333 }T +T{ VAL1 -> 222 }T +T{ 123 VALUE VAL3 IMMEDIATE VAL3 -> 123 }T +T{ : VD3 VAL3 LITERAL ; VD3 -> 123 }T + +\ ----------------------------------------------------------------------------- +testing CASE OF ENDOF ENDCASE + +: CS1 CASE 1 OF 111 ENDOF + 2 OF 222 ENDOF + 3 OF 333 ENDOF + >r 999 r> + ENDCASE +; + +T{ 1 CS1 -> 111 }T +T{ 2 CS1 -> 222 }T +T{ 3 CS1 -> 333 }T +T{ 4 CS1 -> 999 }T + +\ Nested CASE's + +: CS2 >r CASE -1 OF CASE r@ 1 OF 100 ENDOF + 2 OF 200 ENDOF + >r -300 r> + ENDCASE + ENDOF + -2 OF CASE r@ 1 OF -99 ENDOF + >r -199 r> + ENDCASE + ENDOF + >r 299 r> + ENDCASE r> drop +; + +T{ -1 1 CS2 -> 100 }T +T{ -1 2 CS2 -> 200 }T +T{ -1 3 CS2 -> -300 }T +T{ -2 1 CS2 -> -99 }T +T{ -2 2 CS2 -> -199 }T +T{ 0 2 CS2 -> 299 }T + +\ Boolean short circuiting using CASE + +: CS3 ( N1 -- N2 ) + CASE 1- false OF 11 ENDOF + 1- false OF 22 ENDOF + 1- false OF 33 ENDOF + 44 swap + ENDCASE +; + +T{ 1 CS3 -> 11 }T +T{ 2 CS3 -> 22 }T +T{ 3 CS3 -> 33 }T +T{ 9 CS3 -> 44 }T + +\ Empty CASE statements with/without default + +T{ : CS4 CASE ENDCASE ; 1 CS4 -> }T +T{ : CS5 CASE 2 swap ENDCASE ; 1 CS5 -> 2 }T +T{ : CS6 CASE 1 OF ENDOF 2 ENDCASE ; 1 CS6 -> }T +T{ : CS7 CASE 3 OF ENDOF 2 ENDCASE ; 1 CS7 -> 1 }T + +\ ----------------------------------------------------------------------------- +testing :NONAME RECURSE + +variable NN1 +variable NN2 +:NONAME 1234 ; NN1 ! +:NONAME 9876 ; NN2 ! +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 + +\ ----------------------------------------------------------------------------- +testing C" + +T{ : CQ1 C" 123" ; -> }T +T{ CQ1 COUNT EVALUATE -> 123 }T +T{ : CQ2 C" " ; -> }T +T{ CQ2 COUNT EVALUATE -> }T +T{ : CQ3 C" 2345"COUNT EVALUATE ; CQ3 -> 2345 }T + +\ ----------------------------------------------------------------------------- +testing COMPILE, + +:NONAME dup + ; constant dup+ +T{ : Q dup+ COMPILE, ; -> }T +T{ : AS1 [ Q ] ; -> }T +T{ 123 AS1 -> 246 }T + +\ ----------------------------------------------------------------------------- +\ Cannot automatically test SAVE-INPUT and RESTORE-INPUT from a console source + +testing SAVE-INPUT and RESTORE-INPUT with a string source + +variable SI_INC 0 SI_INC ! + +: SI1 + SI_INC @ >IN +! + 15 SI_INC ! +; + +: S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ; + +T{ S$ EVALUATE SI_INC @ -> 0 2345 15 }T + +\ ----------------------------------------------------------------------------- +testing .( + +CR CR .( Output from .() +T{ CR .( You should see -9876: ) -9876 . -> }T +T{ CR .( and again: ).( -9876)CR -> }T + +CR CR .( On the next 2 lines you should see First then Second messages:) +T{ : DOTP CR ." Second message via ." [char] " EMIT \ Check .( is immediate + [ CR ] .( First message via .( ) ; DOTP -> }T +CR CR +T{ : IMM? bl word find nip ; IMM? .( -> 1 }T + +\ ----------------------------------------------------------------------------- +testing .R and U.R - has to handle different cell sizes + +\ Create some large integers just below/above MAX and Min INTs +max-int 73 79 */ constant LI1 +min-int 71 73 */ constant LI2 + +LI1 0 <# #S #> nip constant LENLI1 + +: (.R&U.R) ( u1 u2 -- ) \ u1 <= string length, u2 is required indentation + tuck + >r + LI1 over SPACES . CR r@ LI1 swap .R CR + LI2 over SPACES . CR r@ 1+ LI2 swap .R CR + LI1 over SPACES U. CR r@ LI1 swap U.R CR + LI2 swap SPACES U. CR r> LI2 swap U.R CR +; + +: .R&U.R ( -- ) + CR ." You should see lines duplicated:" CR + ." indented by 0 spaces" CR 0 0 (.R&U.R) CR + ." indented by 0 spaces" CR LENLI1 0 (.R&U.R) CR \ Just fits required width + ." indented by 5 spaces" CR LENLI1 5 (.R&U.R) CR +; + +CR CR .( Output from .R and U.R) +T{ .R&U.R -> }T + +\ ----------------------------------------------------------------------------- +testing PAD ERASE +\ Must handle different size characters i.e. 1 CHARS >= 1 + +84 constant CHARS/PAD \ Minimum size of PAD in chars +CHARS/PAD CHARS constant AUS/PAD +: CHECKPAD ( caddr u ch -- f ) \ f = true if u chars = ch + swap 0 + ?do + over i CHARS + C@ over <> + if 2drop UNLOOP false exit then + loop + 2drop true +; + +T{ PAD drop -> }T +T{ 0 invert PAD C! -> }T +T{ PAD C@ constant MAXCHAR -> }T +T{ PAD CHARS/PAD 2DUP MAXCHAR FILL MAXCHAR CHECKPAD -> true }T +T{ PAD CHARS/PAD 2DUP CHARS ERASE 0 CHECKPAD -> true }T +T{ PAD CHARS/PAD 2DUP MAXCHAR FILL PAD 0 ERASE MAXCHAR CHECKPAD -> true }T +T{ PAD 43 CHARS + 9 CHARS ERASE -> }T +T{ PAD 43 MAXCHAR CHECKPAD -> true }T +T{ PAD 43 CHARS + 9 0 CHECKPAD -> true }T +T{ PAD 52 CHARS + CHARS/PAD 52 - MAXCHAR CHECKPAD -> true }T + +\ Check that use of word and pictured numeric output do not corrupt PAD +\ Minimum size of buffers for these are 33 chars and (2*n)+2 chars respectively +\ where n is number of bits per cell + +PAD CHARS/PAD ERASE +2 base ! +max-uint max-uint <# #S char 1 dup HOLD HOLD #> 2drop +decimal +bl word 12345678123456781234567812345678 drop +T{ PAD CHARS/PAD 0 CHECKPAD -> true }T + +\ ----------------------------------------------------------------------------- +testing PARSE + +T{ char | PARSE 1234| dup rot rot EVALUATE -> 4 1234 }T +T{ char ^ PARSE 23 45 ^ dup rot rot EVALUATE -> 7 23 45 }T +: PA1 [char] $ PARSE dup >r PAD swap CHARS MOVE PAD r> ; +T{ PA1 3456 + dup rot rot EVALUATE -> 4 3456 }T +T{ char A PARSE A swap drop -> 0 }T +T{ char Z PARSE + swap drop -> 0 }T +T{ char " PARSE 4567 "dup rot rot EVALUATE -> 5 4567 }T + +\ ----------------------------------------------------------------------------- +testing PARSE-NAME (Forth 2012) +\ Adapted from the PARSE-NAME RfD tests + +T{ PARSE-NAME abcd STR1 S= -> true }T \ No leading spaces +T{ PARSE-NAME abcde STR2 S= -> true }T \ Leading spaces + +\ Test empty parse area, new lines are necessary +T{ PARSE-NAME + nip -> 0 }T +\ Empty parse area with spaces after PARSE-NAME +T{ PARSE-NAME + nip -> 0 }T + +T{ : PARSE-NAME-TEST ( "name1" "name2" -- n ) + PARSE-NAME PARSE-NAME S= ; -> }T +T{ PARSE-NAME-TEST abcd abcd -> true }T +T{ PARSE-NAME-TEST abcd abcd -> true }T \ Leading spaces +T{ PARSE-NAME-TEST abcde abcdf -> false }T +T{ PARSE-NAME-TEST abcdf abcde -> false }T +T{ PARSE-NAME-TEST abcde abcde + -> true }T \ Parse to end of line +T{ PARSE-NAME-TEST abcde abcde + -> true }T \ Leading and trailing spaces + +\ ----------------------------------------------------------------------------- +testing DEFER DEFEr@ DEFER! IS ACTION-OF (Forth 2012) +\ Adapted from the Forth 200X RfD tests + +T{ DEFER DEFER1 -> }T +T{ : MY-DEFER DEFER ; -> }T +T{ : IS-DEFER1 IS DEFER1 ; -> }T +T{ : ACTION-DEFER1 ACTION-OF DEFER1 ; -> }T +T{ : DEF! DEFER! ; -> }T +T{ : DEF@ DEFEr@ ; -> }T + +T{ ' * ' DEFER1 DEFER! -> }T +T{ 2 3 DEFER1 -> 6 }T +T{ ' DEFER1 DEFEr@ -> ' * }T +T{ ' DEFER1 DEF@ -> ' * }T +T{ ACTION-OF DEFER1 -> ' * }T +T{ ACTION-DEFER1 -> ' * }T +T{ ' + IS DEFER1 -> }T +T{ 1 2 DEFER1 -> 3 }T +T{ ' DEFER1 DEFEr@ -> ' + }T +T{ ' DEFER1 DEF@ -> ' + }T +T{ ACTION-OF DEFER1 -> ' + }T +T{ ACTION-DEFER1 -> ' + }T +T{ ' - IS-DEFER1 -> }T +T{ 1 2 DEFER1 -> -1 }T +T{ ' DEFER1 DEFEr@ -> ' - }T +T{ ' DEFER1 DEF@ -> ' - }T +T{ ACTION-OF DEFER1 -> ' - }T +T{ ACTION-DEFER1 -> ' - }T + +T{ MY-DEFER DEFER2 -> }T +T{ ' dup IS DEFER2 -> }T +T{ 1 DEFER2 -> 1 1 }T + +\ ----------------------------------------------------------------------------- +testing HOLDS (Forth 2012) + +: HTEST S" Testing HOLDS" ; +: HTEST2 S" works" ; +: HTEST3 S" Testing HOLDS works 123" ; +T{ 0 0 <# HTEST HOLDS #> HTEST S= -> true }T +T{ 123 0 <# #S bl HOLD HTEST2 HOLDS bl HOLD HTEST HOLDS #> + HTEST3 S= -> true }T +T{ : HLD HOLDS ; -> }T +T{ 0 0 <# HTEST HLD #> HTEST S= -> true }T + +\ ----------------------------------------------------------------------------- +testing REFILL SOURCE-ID +\ REFILL and SOURCE-ID from the user input device can't be tested from a file, +\ can only be tested from a string via EVALUATE + +T{ : RF1 S" REFILL" EVALUATE ; RF1 -> false }T +T{ : SID1 S" SOURCE-ID" EVALUATE ; SID1 -> -1 }T + +\ ------------------------------------------------------------------------------ +testing S\" (Forth 2012 compilation mode) +\ Extended the Forth 200X RfD tests +\ Note this tests the Core Ext definition of S\" which has unedfined +\ interpretation semantics. S\" in interpretation mode is tested in the tests on +\ the File-Access word set + +T{ : SSQ1 S\" abc" S" abc" S= ; -> }T \ No escapes +T{ SSQ1 -> true }T +T{ : SSQ2 S\" " ; SSQ2 swap drop -> 0 }T \ Empty string + +T{ : SSQ3 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T +T{ SSQ3 swap drop -> 20 }T \ String length +T{ SSQ3 drop C@ -> 7 }T \ \a BEL Bell +T{ SSQ3 drop 1 CHARS + C@ -> 8 }T \ \b BS Backspace +T{ SSQ3 drop 2 CHARS + C@ -> 27 }T \ \e ESC Escape +T{ SSQ3 drop 3 CHARS + C@ -> 12 }T \ \f FF Form feed +T{ SSQ3 drop 4 CHARS + C@ -> 10 }T \ \l LF Line feed +T{ SSQ3 drop 5 CHARS + C@ -> 13 }T \ \m CR of CR/LF pair +T{ SSQ3 drop 6 CHARS + C@ -> 10 }T \ LF of CR/LF pair +T{ SSQ3 drop 7 CHARS + C@ -> 34 }T \ \q " Double Quote +T{ SSQ3 drop 8 CHARS + C@ -> 13 }T \ \r CR Carriage Return +T{ SSQ3 drop 9 CHARS + C@ -> 9 }T \ \t TAB Horizontal Tab +T{ SSQ3 drop 10 CHARS + C@ -> 11 }T \ \v VT Vertical Tab +T{ SSQ3 drop 11 CHARS + C@ -> 15 }T \ \x0F Given Char +T{ SSQ3 drop 12 CHARS + C@ -> 48 }T \ 0 0 Digit follow on +T{ SSQ3 drop 13 CHARS + C@ -> 31 }T \ \x1F Given Char +T{ SSQ3 drop 14 CHARS + C@ -> 97 }T \ a a Hex follow on +T{ SSQ3 drop 15 CHARS + C@ -> 171 }T \ \xaB Insensitive Given Char +T{ SSQ3 drop 16 CHARS + C@ -> 120 }T \ x x Non hex follow on +T{ SSQ3 drop 17 CHARS + C@ -> 0 }T \ \z NUL No Character +T{ SSQ3 drop 18 CHARS + C@ -> 34 }T \ \" " Double Quote +T{ SSQ3 drop 19 CHARS + C@ -> 92 }T \ \\ \ Back Slash + +\ The above does not test \n as this is a system dependent value. +\ Check it displays a new line +CR .( The next test should display:) +CR .( One line...) +CR .( another line) +T{ : SSQ4 S\" \nOne line...\nanotherLine\n" TYPE ; SSQ4 -> }T + +\ Test bare escapable characters appear as themselves +T{ : SSQ5 S\" abeflmnqrtvxz" S" abeflmnqrtvxz" S= ; SSQ5 -> true }T + +T{ : SSQ6 S\" a\""2drop 1111 ; SSQ6 -> 1111 }T \ Parsing behaviour + +T{ : SSQ7 S\" 111 : SSQ8 S\\\" 222\" EVALUATE ; SSQ8 333" EVALUATE ; -> }T +T{ SSQ7 -> 111 222 333 }T +T{ : SSQ9 S\" 11 : SSQ10 S\\\" \\x32\\x32\" EVALUATE ; SSQ10 33" EVALUATE ; -> }T +T{ SSQ9 -> 11 22 33 }T + +\ ----------------------------------------------------------------------------- +CORE-EXT-ERRORS SET-ERROR-COUNT + +CR .( End of Core Extension word tests) CR + + diff --git a/test/errorreport.fs b/test/errorreport.fs new file mode 100644 index 0000000..4ea942d --- /dev/null +++ b/test/errorreport.fs @@ -0,0 +1,78 @@ +\ planckforth - +\ Copyright (C) 2021 nineties + +\ test/tester.fs and test codes are base on +\ https://github.com/gerryjackson/forth2012-test-suite + +decimal + +variable total-errors + +: error-count ( "name" n1 -- n2 ) \ n2 = n1 + 1cell + create dup , cell+ + does> ( -- offset ) @ \ offset in address units +; + +0 \ Offset into errors[] array +error-count core-errors error-count core-ext-errors +error-count double-errors error-count exception-errors +error-count facility-errors error-count file-errors +error-count locals-errors error-count memory-errors +error-count searchorder-errors error-count string-errors +error-count tools-errors error-count block-errors +create errors[] dup allot constant #error-counts + +\ set-error-count called at the end of each test file with its own offset into +\ the errors[] array. #error is in files tester.fr and ttester.fs + +: set-error-count ( offset -- ) + #error @ swap errors[] + ! + #error @ total-errors +! + 0 #error ! +; + +: init-errors ( -- ) + errors[] #error-counts over + swap do -1 i ! 1 cells +loop + 0 total-errors ! + core-errors set-error-count +; + +init-errors + +\ Report summary of errors + +25 constant margin + +: show-error-line ( n caddr -- ) + cr dup strlen swap type margin - abs >r + dup -1 = if drop r> 1- spaces ." -" else + r> .r then +; + +: show-error-count ( caddr offset -- ) + errors[] + @ swap show-error-line +; + +: hline ( -- ) cr ." ---------------------------" ; + +: report-errors + hline + cr 8 spaces ." Error Report" + cr ." Word Set" 13 spaces ." Errors" + hline + s" Core" core-errors show-error-count + s" Core extension" core-ext-errors show-error-count + s" Block" block-errors show-error-count + s" Double number" double-errors show-error-count + s" Exception" exception-errors show-error-count + s" Facility" facility-errors show-error-count + s" File-access" file-errors show-error-count + s" Locals" locals-errors show-error-count + s" Memory-allocation" memory-errors show-error-count + s" Programming-tools" tools-errors show-error-count + s" Search-order" searchorder-errors show-error-count + s" String" string-errors show-error-count + hline + total-errors @ s" Total" show-error-line + hline cr cr +;