From ba72da7872c6d3ed9c9dabca243474aff49068e1 Mon Sep 17 00:00:00 2001 From: juju2013 Date: Thu, 31 Oct 2019 09:31:54 +0000 Subject: [PATCH] import from 2.4.8 --- CHANGELOG | 6 + README | 3 +- common/ansification-tester.txt | 2481 +++++++++++++++++ common/ansification.txt | 236 ++ ...stellaris-linux-with-disassembler-and-math | Bin 36556 -> 36644 bytes mecrisp-stellaris-source/common/compiler.s | 10 +- .../common/controlstructures.s | 1 + .../common/datastackandmacros.s | 8 +- mecrisp-stellaris-source/common/deepinsight.s | 102 +- mecrisp-stellaris-source/common/forth-core.s | 1 + mecrisp-stellaris-source/common/interpreter.s | 6 +- .../common/ra/controlstructures.s | 1 + .../common/ra/interpreter.s | 6 +- mecrisp-stellaris-source/common/strings.s | 69 +- mecrisp-stellaris-source/common/token.s | 8 +- .../xmc1100-ra/terminal.s | 2 +- mecrisp-stellaris-source/xmc1100/terminal.s | 2 +- 17 files changed, 2854 insertions(+), 88 deletions(-) create mode 100644 common/ansification-tester.txt create mode 100644 common/ansification.txt diff --git a/CHANGELOG b/CHANGELOG index b657168..3334ea0 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -719,3 +719,9 @@ - New target: Numworks calculator - Contribution by Wolfgang Strauss: Forth drivers for Numworks calculator + +29.12.2018, Matthias Koch, Mecrisp-Stellaris 2.4.8, 35C3 edition + + - Added UNUSED to all cores to get current amount of free memory + - Added ansification.txt for adjusting Mecrisp-Stellaris as close as possible to standard Forth + - Adjusted baud rate in XMC1100 diff --git a/README b/README index f7c862c..1b7d46d 100644 --- a/README +++ b/README @@ -1100,6 +1100,7 @@ Deep insights: cell+ ( x -- x+4 ) Add size of one cell cells ( n -- 4*n ) Calculate size of n cells + unused ( -- u ) Get current amount of free memory allot ( n -- ) Tries to advance Dictionary Pointer by n bytes Aborts, if not enough space available here ( -- a-addr|c-addr ) @@ -2036,4 +2037,4 @@ System: bye ( -- ) Leave Mecrisp-Stellaris -Matthias Koch, Summer 2013, updated Spring 2016 +Matthias Koch, Summer 2013, updated Winter 2019 diff --git a/common/ansification-tester.txt b/common/ansification-tester.txt new file mode 100644 index 0000000..5334ebc --- /dev/null +++ b/common/ansification-tester.txt @@ -0,0 +1,2481 @@ + +\ For testing of the ansification layer. Slightly changed, some parts are commented out. +\ See original at https://github.com/gerryjackson/forth2012-test-suite/tree/master + + +\ From: John Hayes S1I +\ Subject: tester.fr +\ Date: Mon, 27 Nov 95 13:10:09 PST + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. +\ VERSION 1.2 + +\ 24/11/2015 Replaced Core Ext word <> with = 0= +\ 31/3/2015 Variable #ERRORS added and incremented for each error reported. +\ 22/1/09 The words { and } have been changed to T{ and }T respectively to +\ agree with the Forth 200X file ttester.fs. This avoids clashes with +\ locals using { ... } and the FSL use of } + +HEX + +\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY +\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. +VARIABLE VERBOSE + FALSE VERBOSE ! +\ TRUE VERBOSE ! + +: EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. + DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ; + +VARIABLE #ERRORS 0 #ERRORS ! + +: ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY + \ THE LINE THAT HAD THE ERROR. + CR TYPE SOURCE TYPE \ DISPLAY LINE CORRESPONDING TO ERROR + EMPTY-STACK \ THROW AWAY EVERY THING ELSE + #ERRORS @ 1 + #ERRORS ! +\ QUIT \ *** Uncomment this line to QUIT on an error +; + +VARIABLE ACTUAL-DEPTH \ STACK RECORD +CREATE ACTUAL-RESULTS 20 CELLS ALLOT + +: T{ \ ( -- ) SYNTACTIC SUGAR. + ; + +: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. + DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH + ?DUP IF \ IF THERE IS SOMETHING ON STACK + 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM + THEN ; + +: }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED + \ (ACTUAL) CONTENTS. + DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH + DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK + 0 DO \ FOR EACH STACK ITEM + ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED + = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN + LOOP + THEN + ELSE \ DEPTH MISMATCH + S" WRONG NUMBER OF RESULTS: " ERROR + THEN ; + +: TESTING \ ( -- ) TALKING COMMENT. + SOURCE VERBOSE @ + IF DUP >R TYPE CR R> >IN ! + ELSE >IN ! DROP [CHAR] * EMIT + THEN ; + +\ From: John Hayes S1I +\ Subject: core.fr +\ Date: Mon, 27 Nov 95 13:10 + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. +\ VERSION 1.2 +\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM. +\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE +\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND +\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1. +\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"... +\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?... + +CR +TESTING CORE WORDS +HEX + +\ ------------------------------------------------------------------------ +TESTING BASIC ASSUMPTIONS + +T{ -> }T \ START WITH CLEAN SLATE +( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) +T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T +T{ 0 BITSSET? -> 0 }T ( ZERO IS ALL BITS CLEAR ) +T{ 1 BITSSET? -> 0 0 }T ( OTHER NUMBER HAVE AT LEAST ONE BIT ) +T{ -1 BITSSET? -> 0 0 }T + +\ ------------------------------------------------------------------------ +TESTING BOOLEANS: INVERT AND OR XOR + +T{ 0 0 AND -> 0 }T +T{ 0 1 AND -> 0 }T +T{ 1 0 AND -> 0 }T +T{ 1 1 AND -> 1 }T + +T{ 0 INVERT 1 AND -> 1 }T +T{ 1 INVERT 1 AND -> 0 }T + +0 CONSTANT 0S +0 INVERT CONSTANT 1S + +T{ 0S INVERT -> 1S }T +T{ 1S INVERT -> 0S }T + +T{ 0S 0S AND -> 0S }T +T{ 0S 1S AND -> 0S }T +T{ 1S 0S AND -> 0S }T +T{ 1S 1S AND -> 1S }T + +T{ 0S 0S OR -> 0S }T +T{ 0S 1S OR -> 1S }T +T{ 1S 0S OR -> 1S }T +T{ 1S 1S OR -> 1S }T + +T{ 0S 0S XOR -> 0S }T +T{ 0S 1S XOR -> 1S }T +T{ 1S 0S XOR -> 1S }T +T{ 1S 1S XOR -> 0S }T + +\ ------------------------------------------------------------------------ +TESTING 2* 2/ LSHIFT RSHIFT + +( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) +1S 1 RSHIFT INVERT CONSTANT MSB +T{ MSB BITSSET? -> 0 0 }T + +T{ 0S 2* -> 0S }T +T{ 1 2* -> 2 }T +T{ 4000 2* -> 8000 }T +T{ 1S 2* 1 XOR -> 1S }T +T{ MSB 2* -> 0S }T + +T{ 0S 2/ -> 0S }T +T{ 1 2/ -> 0 }T +T{ 4000 2/ -> 2000 }T +T{ 1S 2/ -> 1S }T \ MSB PROPOGATED +T{ 1S 1 XOR 2/ -> 1S }T +T{ MSB 2/ MSB AND -> MSB }T + +T{ 1 0 LSHIFT -> 1 }T +T{ 1 1 LSHIFT -> 2 }T +T{ 1 2 LSHIFT -> 4 }T +T{ 1 F LSHIFT -> 8000 }T \ BIGGEST GUARANTEED SHIFT +T{ 1S 1 LSHIFT 1 XOR -> 1S }T +T{ MSB 1 LSHIFT -> 0 }T + +T{ 1 0 RSHIFT -> 1 }T +T{ 1 1 RSHIFT -> 0 }T +T{ 2 1 RSHIFT -> 1 }T +T{ 4 2 RSHIFT -> 1 }T +T{ 8000 F RSHIFT -> 1 }T \ BIGGEST +T{ MSB 1 RSHIFT MSB AND -> 0 }T \ RSHIFT ZERO FILLS MSBS +T{ MSB 1 RSHIFT 2* -> MSB }T + +\ ------------------------------------------------------------------------ +TESTING COMPARISONS: 0= = 0< < > U< MIN MAX +0 INVERT CONSTANT MAX-UINT +0 INVERT 1 RSHIFT CONSTANT MAX-INT +0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT +0 INVERT 1 RSHIFT CONSTANT MID-UINT +0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 + +0S CONSTANT +1S CONSTANT + +T{ 0 0= -> }T +T{ 1 0= -> }T +T{ 2 0= -> }T +T{ -1 0= -> }T +T{ MAX-UINT 0= -> }T +T{ MIN-INT 0= -> }T +T{ MAX-INT 0= -> }T + +T{ 0 0 = -> }T +T{ 1 1 = -> }T +T{ -1 -1 = -> }T +T{ 1 0 = -> }T +T{ -1 0 = -> }T +T{ 0 1 = -> }T +T{ 0 -1 = -> }T + +T{ 0 0< -> }T +T{ -1 0< -> }T +T{ MIN-INT 0< -> }T +T{ 1 0< -> }T +T{ MAX-INT 0< -> }T + +T{ 0 1 < -> }T +T{ 1 2 < -> }T +T{ -1 0 < -> }T +T{ -1 1 < -> }T +T{ MIN-INT 0 < -> }T +T{ MIN-INT MAX-INT < -> }T +T{ 0 MAX-INT < -> }T +T{ 0 0 < -> }T +T{ 1 1 < -> }T +T{ 1 0 < -> }T +T{ 2 1 < -> }T +T{ 0 -1 < -> }T +T{ 1 -1 < -> }T +T{ 0 MIN-INT < -> }T +T{ MAX-INT MIN-INT < -> }T +T{ MAX-INT 0 < -> }T + +T{ 0 1 > -> }T +T{ 1 2 > -> }T +T{ -1 0 > -> }T +T{ -1 1 > -> }T +T{ MIN-INT 0 > -> }T +T{ MIN-INT MAX-INT > -> }T +T{ 0 MAX-INT > -> }T +T{ 0 0 > -> }T +T{ 1 1 > -> }T +T{ 1 0 > -> }T +T{ 2 1 > -> }T +T{ 0 -1 > -> }T +T{ 1 -1 > -> }T +T{ 0 MIN-INT > -> }T +T{ MAX-INT MIN-INT > -> }T +T{ MAX-INT 0 > -> }T + +T{ 0 1 U< -> }T +T{ 1 2 U< -> }T +T{ 0 MID-UINT U< -> }T +T{ 0 MAX-UINT U< -> }T +T{ MID-UINT MAX-UINT U< -> }T +T{ 0 0 U< -> }T +T{ 1 1 U< -> }T +T{ 1 0 U< -> }T +T{ 2 1 U< -> }T +T{ MID-UINT 0 U< -> }T +T{ MAX-UINT 0 U< -> }T +T{ MAX-UINT MID-UINT U< -> }T + +T{ 0 1 MIN -> 0 }T +T{ 1 2 MIN -> 1 }T +T{ -1 0 MIN -> -1 }T +T{ -1 1 MIN -> -1 }T +T{ MIN-INT 0 MIN -> MIN-INT }T +T{ MIN-INT MAX-INT MIN -> MIN-INT }T +T{ 0 MAX-INT MIN -> 0 }T +T{ 0 0 MIN -> 0 }T +T{ 1 1 MIN -> 1 }T +T{ 1 0 MIN -> 0 }T +T{ 2 1 MIN -> 1 }T +T{ 0 -1 MIN -> -1 }T +T{ 1 -1 MIN -> -1 }T +T{ 0 MIN-INT MIN -> MIN-INT }T +T{ MAX-INT MIN-INT MIN -> MIN-INT }T +T{ MAX-INT 0 MIN -> 0 }T + +T{ 0 1 MAX -> 1 }T +T{ 1 2 MAX -> 2 }T +T{ -1 0 MAX -> 0 }T +T{ -1 1 MAX -> 1 }T +T{ MIN-INT 0 MAX -> 0 }T +T{ MIN-INT MAX-INT MAX -> MAX-INT }T +T{ 0 MAX-INT MAX -> MAX-INT }T +T{ 0 0 MAX -> 0 }T +T{ 1 1 MAX -> 1 }T +T{ 1 0 MAX -> 1 }T +T{ 2 1 MAX -> 2 }T +T{ 0 -1 MAX -> 0 }T +T{ 1 -1 MAX -> 1 }T +T{ 0 MIN-INT MAX -> 0 }T +T{ MAX-INT MIN-INT MAX -> MAX-INT }T +T{ MAX-INT 0 MAX -> MAX-INT }T + +\ ------------------------------------------------------------------------ +TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP + +T{ 1 2 2DROP -> }T +T{ 1 2 2DUP -> 1 2 1 2 }T +T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T +T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T +T{ 0 ?DUP -> 0 }T +T{ 1 ?DUP -> 1 1 }T +T{ -1 ?DUP -> -1 -1 }T +T{ DEPTH -> 0 }T +T{ 0 DEPTH -> 0 1 }T +T{ 0 1 DEPTH -> 0 1 2 }T +T{ 0 DROP -> }T +T{ 1 2 DROP -> 1 }T +T{ 1 DUP -> 1 1 }T +T{ 1 2 OVER -> 1 2 1 }T +T{ 1 2 3 ROT -> 2 3 1 }T +T{ 1 2 SWAP -> 2 1 }T + +\ ------------------------------------------------------------------------ +TESTING >R R> R@ + +T{ : GR1 >R R> ; -> }T +T{ : GR2 >R R@ R> DROP ; -> }T +T{ 123 GR1 -> 123 }T +T{ 123 GR2 -> 123 }T +T{ 1S GR1 -> 1S }T ( RETURN STACK HOLDS CELLS ) + +\ ------------------------------------------------------------------------ +TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE + +T{ 0 5 + -> 5 }T +T{ 5 0 + -> 5 }T +T{ 0 -5 + -> -5 }T +T{ -5 0 + -> -5 }T +T{ 1 2 + -> 3 }T +T{ 1 -2 + -> -1 }T +T{ -1 2 + -> 1 }T +T{ -1 -2 + -> -3 }T +T{ -1 1 + -> 0 }T +T{ MID-UINT 1 + -> MID-UINT+1 }T + +T{ 0 5 - -> -5 }T +T{ 5 0 - -> 5 }T +T{ 0 -5 - -> 5 }T +T{ -5 0 - -> -5 }T +T{ 1 2 - -> -1 }T +T{ 1 -2 - -> 3 }T +T{ -1 2 - -> -3 }T +T{ -1 -2 - -> 1 }T +T{ 0 1 - -> -1 }T +T{ MID-UINT+1 1 - -> MID-UINT }T + +T{ 0 1+ -> 1 }T +T{ -1 1+ -> 0 }T +T{ 1 1+ -> 2 }T +T{ MID-UINT 1+ -> MID-UINT+1 }T + +T{ 2 1- -> 1 }T +T{ 1 1- -> 0 }T +T{ 0 1- -> -1 }T +T{ MID-UINT+1 1- -> MID-UINT }T + +T{ 0 NEGATE -> 0 }T +T{ 1 NEGATE -> -1 }T +T{ -1 NEGATE -> 1 }T +T{ 2 NEGATE -> -2 }T +T{ -2 NEGATE -> 2 }T + +T{ 0 ABS -> 0 }T +T{ 1 ABS -> 1 }T +T{ -1 ABS -> 1 }T +T{ MIN-INT ABS -> MID-UINT+1 }T + +\ ------------------------------------------------------------------------ +TESTING MULTIPLY: S>D * M* UM* + +T{ 0 S>D -> 0 0 }T +T{ 1 S>D -> 1 0 }T +T{ 2 S>D -> 2 0 }T +T{ -1 S>D -> -1 -1 }T +T{ -2 S>D -> -2 -1 }T +T{ MIN-INT S>D -> MIN-INT -1 }T +T{ MAX-INT S>D -> MAX-INT 0 }T + +T{ 0 0 M* -> 0 S>D }T +T{ 0 1 M* -> 0 S>D }T +T{ 1 0 M* -> 0 S>D }T +T{ 1 2 M* -> 2 S>D }T +T{ 2 1 M* -> 2 S>D }T +T{ 3 3 M* -> 9 S>D }T +T{ -3 3 M* -> -9 S>D }T +T{ 3 -3 M* -> -9 S>D }T +T{ -3 -3 M* -> 9 S>D }T +T{ 0 MIN-INT M* -> 0 S>D }T +T{ 1 MIN-INT M* -> MIN-INT S>D }T +T{ 2 MIN-INT M* -> 0 1S }T +T{ 0 MAX-INT M* -> 0 S>D }T +T{ 1 MAX-INT M* -> MAX-INT S>D }T +T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T +T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T +T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T +T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T + +T{ 0 0 * -> 0 }T \ TEST IDENTITIES +T{ 0 1 * -> 0 }T +T{ 1 0 * -> 0 }T +T{ 1 2 * -> 2 }T +T{ 2 1 * -> 2 }T +T{ 3 3 * -> 9 }T +T{ -3 3 * -> -9 }T +T{ 3 -3 * -> -9 }T +T{ -3 -3 * -> 9 }T + +T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T +T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T +T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T + +T{ 0 0 UM* -> 0 0 }T +T{ 0 1 UM* -> 0 0 }T +T{ 1 0 UM* -> 0 0 }T +T{ 1 2 UM* -> 2 0 }T +T{ 2 1 UM* -> 2 0 }T +T{ 3 3 UM* -> 9 0 }T + +T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T +T{ MID-UINT+1 2 UM* -> 0 1 }T +T{ MID-UINT+1 4 UM* -> 0 2 }T +T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T +T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T + +\ ------------------------------------------------------------------------ +TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD + +T{ 0 S>D 1 FM/MOD -> 0 0 }T +T{ 1 S>D 1 FM/MOD -> 0 1 }T +T{ 2 S>D 1 FM/MOD -> 0 2 }T +T{ -1 S>D 1 FM/MOD -> 0 -1 }T +T{ -2 S>D 1 FM/MOD -> 0 -2 }T +T{ 0 S>D -1 FM/MOD -> 0 0 }T +T{ 1 S>D -1 FM/MOD -> 0 -1 }T +T{ 2 S>D -1 FM/MOD -> 0 -2 }T +T{ -1 S>D -1 FM/MOD -> 0 1 }T +T{ -2 S>D -1 FM/MOD -> 0 2 }T +T{ 2 S>D 2 FM/MOD -> 0 1 }T +T{ -1 S>D -1 FM/MOD -> 0 1 }T +T{ -2 S>D -2 FM/MOD -> 0 1 }T +T{ 7 S>D 3 FM/MOD -> 1 2 }T +T{ 7 S>D -3 FM/MOD -> -2 -3 }T +T{ -7 S>D 3 FM/MOD -> 2 -3 }T +T{ -7 S>D -3 FM/MOD -> -1 2 }T +T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T +T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T +T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T +T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T +T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T +T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T +T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T +T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T +T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T +T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T +T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T +T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T +T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T +T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T +T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T +T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T +T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T + +T{ 0 S>D 1 SM/REM -> 0 0 }T +T{ 1 S>D 1 SM/REM -> 0 1 }T +T{ 2 S>D 1 SM/REM -> 0 2 }T +T{ -1 S>D 1 SM/REM -> 0 -1 }T +T{ -2 S>D 1 SM/REM -> 0 -2 }T +T{ 0 S>D -1 SM/REM -> 0 0 }T +T{ 1 S>D -1 SM/REM -> 0 -1 }T +T{ 2 S>D -1 SM/REM -> 0 -2 }T +T{ -1 S>D -1 SM/REM -> 0 1 }T +T{ -2 S>D -1 SM/REM -> 0 2 }T +T{ 2 S>D 2 SM/REM -> 0 1 }T +T{ -1 S>D -1 SM/REM -> 0 1 }T +T{ -2 S>D -2 SM/REM -> 0 1 }T +T{ 7 S>D 3 SM/REM -> 1 2 }T +T{ 7 S>D -3 SM/REM -> 1 -2 }T +T{ -7 S>D 3 SM/REM -> -1 -2 }T +T{ -7 S>D -3 SM/REM -> -1 2 }T +T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T +T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T +T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T +T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T +T{ 1S 1 4 SM/REM -> 3 MAX-INT }T +T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T +T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T +T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T +T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T +T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T +T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T +T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T +T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T + +T{ 0 0 1 UM/MOD -> 0 0 }T +T{ 1 0 1 UM/MOD -> 0 1 }T +T{ 1 0 2 UM/MOD -> 1 0 }T +T{ 3 0 2 UM/MOD -> 1 1 }T +T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T +T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T +T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T + +: IFFLOORED + [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ; + +: IFSYM + [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ; + +\ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION. +\ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST. + +IFFLOORED : T/MOD >R S>D R> FM/MOD ; +IFFLOORED : T/ T/MOD SWAP DROP ; +IFFLOORED : TMOD T/MOD DROP ; +IFFLOORED : T*/MOD >R M* R> FM/MOD ; +IFFLOORED : T*/ T*/MOD SWAP DROP ; +IFSYM : T/MOD >R S>D R> SM/REM ; +IFSYM : T/ T/MOD SWAP DROP ; +IFSYM : TMOD T/MOD DROP ; +IFSYM : T*/MOD >R M* R> SM/REM ; +IFSYM : T*/ T*/MOD SWAP DROP ; + +T{ 0 1 /MOD -> 0 1 T/MOD }T +T{ 1 1 /MOD -> 1 1 T/MOD }T +T{ 2 1 /MOD -> 2 1 T/MOD }T +T{ -1 1 /MOD -> -1 1 T/MOD }T +T{ -2 1 /MOD -> -2 1 T/MOD }T +T{ 0 -1 /MOD -> 0 -1 T/MOD }T +T{ 1 -1 /MOD -> 1 -1 T/MOD }T +T{ 2 -1 /MOD -> 2 -1 T/MOD }T +T{ -1 -1 /MOD -> -1 -1 T/MOD }T +T{ -2 -1 /MOD -> -2 -1 T/MOD }T +T{ 2 2 /MOD -> 2 2 T/MOD }T +T{ -1 -1 /MOD -> -1 -1 T/MOD }T +T{ -2 -2 /MOD -> -2 -2 T/MOD }T +T{ 7 3 /MOD -> 7 3 T/MOD }T +T{ 7 -3 /MOD -> 7 -3 T/MOD }T +T{ -7 3 /MOD -> -7 3 T/MOD }T +T{ -7 -3 /MOD -> -7 -3 T/MOD }T +T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T +T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T +T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T +T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T + +T{ 0 1 / -> 0 1 T/ }T +T{ 1 1 / -> 1 1 T/ }T +T{ 2 1 / -> 2 1 T/ }T +T{ -1 1 / -> -1 1 T/ }T +T{ -2 1 / -> -2 1 T/ }T +T{ 0 -1 / -> 0 -1 T/ }T +T{ 1 -1 / -> 1 -1 T/ }T +T{ 2 -1 / -> 2 -1 T/ }T +T{ -1 -1 / -> -1 -1 T/ }T +T{ -2 -1 / -> -2 -1 T/ }T +T{ 2 2 / -> 2 2 T/ }T +T{ -1 -1 / -> -1 -1 T/ }T +T{ -2 -2 / -> -2 -2 T/ }T +T{ 7 3 / -> 7 3 T/ }T +T{ 7 -3 / -> 7 -3 T/ }T +T{ -7 3 / -> -7 3 T/ }T +T{ -7 -3 / -> -7 -3 T/ }T +T{ MAX-INT 1 / -> MAX-INT 1 T/ }T +T{ MIN-INT 1 / -> MIN-INT 1 T/ }T +T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T +T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T + +T{ 0 1 MOD -> 0 1 TMOD }T +T{ 1 1 MOD -> 1 1 TMOD }T +T{ 2 1 MOD -> 2 1 TMOD }T +T{ -1 1 MOD -> -1 1 TMOD }T +T{ -2 1 MOD -> -2 1 TMOD }T +T{ 0 -1 MOD -> 0 -1 TMOD }T +T{ 1 -1 MOD -> 1 -1 TMOD }T +T{ 2 -1 MOD -> 2 -1 TMOD }T +T{ -1 -1 MOD -> -1 -1 TMOD }T +T{ -2 -1 MOD -> -2 -1 TMOD }T +T{ 2 2 MOD -> 2 2 TMOD }T +T{ -1 -1 MOD -> -1 -1 TMOD }T +T{ -2 -2 MOD -> -2 -2 TMOD }T +T{ 7 3 MOD -> 7 3 TMOD }T +T{ 7 -3 MOD -> 7 -3 TMOD }T +T{ -7 3 MOD -> -7 3 TMOD }T +T{ -7 -3 MOD -> -7 -3 TMOD }T +T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T +T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T +T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T +T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T + +T{ 0 2 1 */ -> 0 2 1 T*/ }T +T{ 1 2 1 */ -> 1 2 1 T*/ }T +T{ 2 2 1 */ -> 2 2 1 T*/ }T +T{ -1 2 1 */ -> -1 2 1 T*/ }T +T{ -2 2 1 */ -> -2 2 1 T*/ }T +T{ 0 2 -1 */ -> 0 2 -1 T*/ }T +T{ 1 2 -1 */ -> 1 2 -1 T*/ }T +T{ 2 2 -1 */ -> 2 2 -1 T*/ }T +T{ -1 2 -1 */ -> -1 2 -1 T*/ }T +T{ -2 2 -1 */ -> -2 2 -1 T*/ }T +T{ 2 2 2 */ -> 2 2 2 T*/ }T +T{ -1 2 -1 */ -> -1 2 -1 T*/ }T +T{ -2 2 -2 */ -> -2 2 -2 T*/ }T +T{ 7 2 3 */ -> 7 2 3 T*/ }T +T{ 7 2 -3 */ -> 7 2 -3 T*/ }T +T{ -7 2 3 */ -> -7 2 3 T*/ }T +T{ -7 2 -3 */ -> -7 2 -3 T*/ }T +T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T +T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T + +T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T +T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T +T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T +T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T +T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T +T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T +T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T +T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T +T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T +T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T +T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T +T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T +T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T +T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T +T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T +T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T +T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T +T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T +T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T + +\ ------------------------------------------------------------------------ +TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT + +HERE 1 ALLOT +HERE +CONSTANT 2NDA +CONSTANT 1STA +T{ 1STA 2NDA U< -> }T \ HERE MUST GROW WITH ALLOT +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 = -> }T +\ End of extra test + +HERE 1 , +HERE 2 , +CONSTANT 2ND +CONSTANT 1ST +T{ 1ST 2ND U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1ST CELL+ -> 2ND }T \ ... BY ONE CELL +T{ 1ST 1 CELLS + -> 2ND }T +T{ 1ST @ 2ND @ -> 1 2 }T +T{ 5 1ST ! -> }T +T{ 1ST @ 2ND @ -> 5 2 }T +T{ 6 2ND ! -> }T +T{ 1ST @ 2ND @ -> 5 6 }T +T{ 1ST 2@ -> 6 5 }T +T{ 2 1 1ST 2! -> }T +T{ 1ST 2@ -> 2 1 }T +T{ 1S 1ST ! 1ST @ -> 1S }T \ CAN STORE CELL-WIDE VALUE + +HERE 1 C, +HERE 2 C, +CONSTANT 2NDC +CONSTANT 1STC +T{ 1STC 2NDC U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1STC CHAR+ -> 2NDC }T \ ... BY ONE CHAR +T{ 1STC 1 CHARS + -> 2NDC }T +T{ 1STC C@ 2NDC C@ -> 1 2 }T +T{ 3 1STC C! -> }T +T{ 1STC C@ 2NDC C@ -> 3 2 }T +T{ 4 2NDC C! -> }T +T{ 1STC C@ 2NDC C@ -> 3 4 }T + +ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT +CONSTANT A-ADDR CONSTANT UA-ADDR +T{ UA-ADDR ALIGNED -> A-ADDR }T +T{ 1 A-ADDR C! A-ADDR C@ -> 1 }T +T{ 1234 A-ADDR ! A-ADDR @ -> 1234 }T +T{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 }T +T{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 }T +T{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 }T +T{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 }T +T{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 }T + +: BITS ( X -- U ) + 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ; +( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS ) +T{ 1 CHARS 1 < -> }T +T{ 1 CHARS 1 CELLS > -> }T +( TBD: HOW TO FIND NUMBER OF BITS? ) + +( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) +T{ 1 CELLS 1 < -> }T +T{ 1 CELLS 1 CHARS MOD -> 0 }T +T{ 1S BITS 10 < -> }T + +T{ 0 1ST ! -> }T +T{ 1 1ST +! -> }T +T{ 1ST @ -> 1 }T +T{ -1 1ST +! 1ST @ -> 0 }T + +\ ------------------------------------------------------------------------ +TESTING CHAR [CHAR] [ ] BL S" + +T{ BL -> 20 }T +T{ CHAR X -> 58 }T +T{ CHAR HELLO -> 48 }T +T{ : GC1 [CHAR] X ; -> }T +T{ : GC2 [CHAR] HELLO ; -> }T +T{ GC1 -> 58 }T +T{ GC2 -> 48 }T +T{ : GC3 [ GC1 ] LITERAL ; -> }T +T{ GC3 -> 58 }T +T{ : GC4 S" XY" ; -> }T +T{ GC4 SWAP DROP -> 2 }T +T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T + +\ ------------------------------------------------------------------------ +TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE + +T{ : GT1 123 ; -> }T +T{ ' GT1 EXECUTE -> 123 }T +T{ : GT2 ['] GT1 ; IMMEDIATE -> }T +T{ GT2 EXECUTE -> 123 }T +HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING +HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING +T{ GT1STRING FIND -> ' GT1 -1 }T +T{ GT2STRING FIND -> ' GT2 1 }T +( HOW TO SEARCH FOR NON-EXISTENT WORD? ) +T{ : GT3 GT2 LITERAL ; -> }T +T{ GT3 -> ' GT1 }T +T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T + +T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T +T{ : GT5 GT4 ; -> }T +T{ GT5 -> 123 }T +T{ : GT6 345 ; IMMEDIATE -> }T +T{ : GT7 POSTPONE GT6 ; -> }T +T{ GT7 -> 345 }T + +T{ : GT8 STATE @ ; IMMEDIATE -> }T +T{ GT8 -> 0 }T +T{ : GT9 GT8 LITERAL ; -> }T +T{ GT9 0= -> }T + +\ ------------------------------------------------------------------------ +TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE + +T{ : GI1 IF 123 THEN ; -> }T +T{ : GI2 IF 123 ELSE 234 THEN ; -> }T +T{ 0 GI1 -> }T +T{ 1 GI1 -> 123 }T +T{ -1 GI1 -> 123 }T +T{ 0 GI2 -> 234 }T +T{ 1 GI2 -> 123 }T +T{ -1 GI1 -> 123 }T + +T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T +T{ 0 GI3 -> 0 1 2 3 4 5 }T +T{ 4 GI3 -> 4 5 }T +T{ 5 GI3 -> 5 }T +T{ 6 GI3 -> 6 }T + +T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T +T{ 3 GI4 -> 3 4 5 6 }T +T{ 5 GI4 -> 5 6 }T +T{ 6 GI4 -> 6 7 }T + +T{ : GI5 BEGIN DUP 2 > + WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T +T{ 1 GI5 -> 1 345 }T +T{ 2 GI5 -> 2 345 }T +T{ 3 GI5 -> 3 4 5 123 }T +T{ 4 GI5 -> 4 5 123 }T +T{ 5 GI5 -> 5 123 }T + +T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T +T{ 0 GI6 -> 0 }T +T{ 1 GI6 -> 0 1 }T +T{ 2 GI6 -> 0 1 2 }T +T{ 3 GI6 -> 0 1 2 3 }T +T{ 4 GI6 -> 0 1 2 3 4 }T + +\ ------------------------------------------------------------------------ +TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT + +T{ : GD1 DO I LOOP ; -> }T +T{ 4 1 GD1 -> 1 2 3 }T +T{ 2 -1 GD1 -> -1 0 1 }T +T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T + +T{ : GD2 DO I -1 +LOOP ; -> }T +T{ 1 4 GD2 -> 4 3 2 1 }T +T{ -1 2 GD2 -> 2 1 0 -1 }T +T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T + +T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T +T{ 4 1 GD3 -> 1 2 3 }T +T{ 2 -1 GD3 -> -1 0 1 }T +T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T + +T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T +T{ 1 4 GD4 -> 4 3 2 1 }T +T{ -1 2 GD4 -> 2 1 0 -1 }T +T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T + +T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T +T{ 1 GD5 -> 123 }T +T{ 5 GD5 -> 123 }T +T{ 6 GD5 -> 234 }T + +T{ : GD6 ( PAT: T{0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} ) + 0 SWAP 0 DO + I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP + LOOP ; -> }T +T{ 1 GD6 -> 1 }T +T{ 2 GD6 -> 3 }T +T{ 3 GD6 -> 4 1 2 }T + +\ ------------------------------------------------------------------------ +TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY + +T{ 123 CONSTANT X123 -> }T +T{ X123 -> 123 }T +T{ : EQU CONSTANT ; -> }T +T{ X123 EQU Y123 -> }T +T{ Y123 -> 123 }T + +T{ VARIABLE V1 -> }T +T{ 123 V1 ! -> }T +T{ V1 @ -> 123 }T + +T{ : NOP : POSTPONE ; ; -> }T +T{ NOP NOP1 NOP NOP2 -> }T +T{ NOP1 -> }T +T{ NOP2 -> }T + +T{ : DOES1 DOES> @ 1 + ; -> }T +T{ : DOES2 DOES> @ 2 + ; -> }T +T{ CREATE CR1 -> }T +T{ CR1 -> HERE }T +T{ ' CR1 >BODY -> HERE }T +T{ 1 , -> }T +T{ CR1 @ -> 1 }T +T{ DOES1 -> }T +T{ CR1 -> 2 }T +T{ DOES2 -> }T +T{ CR1 -> 3 }T + +T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T +T{ WEIRD: W1 -> }T +T{ ' W1 >BODY -> HERE }T +T{ W1 -> HERE 1 + }T +T{ W1 -> HERE 2 + }T + +\ ------------------------------------------------------------------------ +TESTING EVALUATE + +: GE1 S" 123" ; IMMEDIATE +: GE2 S" 123 1+" ; IMMEDIATE +: GE3 S" : GE4 345 ;" ; +: GE5 EVALUATE ; IMMEDIATE + +T{ GE1 EVALUATE -> 123 }T ( TEST EVALUATE IN INTERP. STATE ) +T{ GE2 EVALUATE -> 124 }T +T{ GE3 EVALUATE -> }T +T{ GE4 -> 345 }T + +T{ : GE6 GE1 GE5 ; -> }T ( TEST EVALUATE IN COMPILE STATE ) +T{ GE6 -> 123 }T +T{ : GE7 GE2 GE5 ; -> }T +T{ GE7 -> 124 }T + +\ ------------------------------------------------------------------------ +TESTING SOURCE >IN WORD + +: GS1 S" SOURCE" 2DUP EVALUATE + >R SWAP >R = R> R> = ; +T{ GS1 -> }T + +VARIABLE SCANS +: RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ; + +T{ 2 SCANS ! +345 RESCAN? +-> 345 345 }T + +: GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ; +T{ GS2 -> 123 123 123 123 123 }T + +: GS3 WORD COUNT SWAP C@ ; +T{ BL GS3 HELLO -> 5 CHAR H }T +T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T +T{ BL GS3 +DROP -> 0 }T \ BLANK LINE RETURN ZERO-LENGTH STRING + +: GS4 SOURCE >IN ! DROP ; +T{ GS4 123 456 +-> }T + +\ ------------------------------------------------------------------------ +TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL + +: S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. + >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH + R> ?DUP IF \ IF NON-EMPTY STRINGS + 0 DO + OVER C@ OVER C@ - IF 2DROP UNLOOP EXIT THEN + SWAP CHAR+ SWAP CHAR+ + LOOP + THEN + 2DROP \ IF WE GET HERE, STRINGS MATCH + ELSE + R> DROP 2DROP \ LENGTHS MISMATCH + THEN ; + +: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; +T{ GP1 -> }T + +: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; +T{ GP2 -> }T + +: GP3 <# 1 0 # # #> S" 01" S= ; +T{ GP3 -> }T + +: GP4 <# 1 0 #S #> S" 1" S= ; +T{ GP4 -> }T + +24 CONSTANT MAX-BASE \ BASE 2 .. 36 +: COUNT-BITS + 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; +COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD + +: GP5 + BASE @ + MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE + I BASE ! \ TBD: ASSUMES BASE WORKS + I 0 <# #S #> S" 10" S= AND + LOOP + SWAP BASE ! ; +T{ GP5 -> }T + +: GP6 + BASE @ >R 2 BASE ! + MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY + R> BASE ! \ S: C-ADDR U + DUP #BITS-UD = SWAP + 0 DO \ S: C-ADDR FLAG + OVER C@ [CHAR] 1 = AND \ ALL ONES + >R CHAR+ R> + LOOP SWAP DROP ; +T{ GP6 -> }T + +: GP7 + BASE @ >R MAX-BASE BASE ! + + A 0 DO + I 0 <# #S #> + 1 = SWAP C@ I 30 + = AND AND + LOOP + MAX-BASE A DO + I 0 <# #S #> + 1 = SWAP C@ 41 I A - + = AND AND + LOOP + R> BASE ! ; + +T{ GP7 -> }T + +\ >NUMBER TESTS +CREATE GN-BUF 0 C, +: GN-STRING GN-BUF 1 ; +: GN-CONSUMED GN-BUF CHAR+ 0 ; +: GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; + +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 +T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T +T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T + +: >NUMBER-BASED + BASE @ >R BASE ! >NUMBER R> BASE ! ; + +T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T +T{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }T +T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T +T{ 0 0 GN' G' 10 >NUMBER-BASED -> 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. + BASE @ >R BASE ! + <# #S #> + 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY + R> BASE ! ; +T{ 0 0 2 GN1 -> 0 0 0 }T +T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T +T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T +T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T +T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T +T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T + +: GN2 \ ( -- 16 10 ) + BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; +T{ GN2 -> 10 A }T + +\ ------------------------------------------------------------------------ +TESTING FILL MOVE + +CREATE FBUF 00 C, 00 C, 00 C, +CREATE SBUF 12 C, 34 C, 56 C, +: SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; + +T{ FBUF 0 20 FILL -> }T +T{ SEEBUF -> 00 00 00 }T + +T{ FBUF 1 20 FILL -> }T +T{ SEEBUF -> 20 00 00 }T + +T{ FBUF 3 20 FILL -> }T +T{ SEEBUF -> 20 20 20 }T + +T{ FBUF FBUF 3 CHARS MOVE -> }T \ BIZARRE SPECIAL CASE +T{ SEEBUF -> 20 20 20 }T + +T{ SBUF FBUF 0 CHARS MOVE -> }T +T{ SEEBUF -> 20 20 20 }T + +T{ SBUF FBUF 1 CHARS MOVE -> }T +T{ SEEBUF -> 12 20 20 }T + +T{ SBUF FBUF 3 CHARS MOVE -> }T +T{ SEEBUF -> 12 34 56 }T + +T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T +T{ SEEBUF -> 12 12 34 }T + +T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T +T{ SEEBUF -> 12 34 34 }T + +\ ------------------------------------------------------------------------ +TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U. + +: OUTPUT-TEST + ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR + 41 BL DO I EMIT LOOP CR + 61 41 DO I EMIT LOOP CR + 7F 61 DO I EMIT LOOP CR + ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR + 9 1+ 0 DO I . LOOP CR + ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR + [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR + ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR + [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR + ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR + 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR + ." YOU SHOULD SEE TWO SEPARATE LINES:" CR + S" LINE 1" TYPE CR S" LINE 2" TYPE CR + ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR + ." SIGNED: " MIN-INT . MAX-INT . CR + ." UNSIGNED: " 0 U. MAX-UINT U. CR +; + +T{ OUTPUT-TEST -> }T + + +\ ------------------------------------------------------------------------ +TESTING INPUT: ACCEPT + +CREATE ABUF 50 CHARS ALLOT + +: ACCEPT-TEST + CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR + ABUF 50 ACCEPT + CR ." RECEIVED: " [CHAR] " EMIT + ABUF SWAP TYPE [CHAR] " EMIT CR +; + +T{ ACCEPT-TEST -> }T + +\ ------------------------------------------------------------------------ +TESTING DICTIONARY SEARCH RULES + +T{ : GDX 123 ; : GDX GDX 234 ; -> }T + +T{ GDX -> 123 234 }T + +CR .( End of Core word set tests) CR + + +\ To test the ANS Forth Core Extension word set + +\ This program was written by Gerry Jackson in 2006, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct + +\ ------------------------------------------------------------------------------ +\ Version 0.13 28 October 2015 +\ Replace and with FALSE and TRUE to avoid +\ dependence on Core tests +\ Moved SAVE-INPUT and RESTORE-INPUT tests in a file to filetest.fth +\ Use of 2VARIABLE (from optional wordset) replaced with CREATE. +\ Minor lower to upper case conversions. +\ Calls to COMPARE replaced by S= (in utilities.fth) to avoid use +\ of a word from an optional word set. +\ UNUSED tests revised as UNUSED UNUSED = may return FALSE when an +\ implementation has the data stack sharing unused dataspace. +\ Double number input dependency removed from the HOLDS tests. +\ Minor case sensitivities removed in definition names. +\ 0.11 25 April 2015 +\ Added tests for PARSE-NAME HOLDS BUFFER: +\ S\" tests added +\ DEFER IS ACTION-OF DEFER! DEFER@ tests added +\ Empty CASE statement test added +\ [COMPILE] tests removed because it is obsolescent in Forth 2012 +\ 0.10 1 August 2014 +\ Added tests contributed by James Bowman for: +\ <> U> 0<> 0> NIP TUCK ROLL PICK 2>R 2R@ 2R> +\ HEX WITHIN UNUSED AGAIN MARKER +\ Added tests for: +\ .R U.R ERASE PAD REFILL SOURCE-ID +\ Removed ABORT from NeverExecuted to enable Win32 +\ to continue after failure of RESTORE-INPUT. +\ Removed max-intx which is no longer used. +\ 0.7 6 June 2012 Extra CASE test added +\ 0.6 1 April 2012 Tests placed in the public domain. +\ SAVE-INPUT & RESTORE-INPUT tests, position +\ of T{ moved so that tests work with ttester.fs +\ CONVERT test deleted - obsolete word removed from Forth 200X +\ IMMEDIATE VALUEs tested +\ RECURSE with :NONAME tested +\ PARSE and .( tested +\ Parsing behaviour of C" added +\ 0.5 14 September 2011 Removed the double [ELSE] from the +\ initial SAVE-INPUT & RESTORE-INPUT test +\ 0.4 30 November 2009 max-int replaced with max-intx to +\ avoid redefinition warnings. +\ 0.3 6 March 2009 { and } replaced with T{ and }T +\ CONVERT test now independent of cell size +\ 0.2 20 April 2007 ANS Forth words changed to upper case +\ Tests qd3 to qd6 by Reinhold Straub +\ 0.1 Oct 2006 First version released +\ ----------------------------------------------------------------------------- +\ The tests are based on John Hayes test program for the core word set + +\ Words tested in this file are: +\ .( .R 0<> 0> 2>R 2R> 2R@ :NONAME <> ?DO AGAIN C" CASE COMPILE, ENDCASE +\ ENDOF ERASE FALSE HEX MARKER NIP OF PAD PARSE PICK REFILL +\ RESTORE-INPUT ROLL SAVE-INPUT SOURCE-ID TO TRUE TUCK U.R U> UNUSED +\ VALUE WITHIN [COMPILE] + +\ Words not tested or partially tested: +\ \ because it has been extensively used already and is, hence, unnecessary +\ REFILL and SOURCE-ID from the user input device which are not possible +\ when testing from a file such as this one +\ UNUSED (partially tested) as the value returned is system dependent +\ Obsolescent words #TIB CONVERT EXPECT QUERY SPAN TIB as they have been +\ removed from the Forth 2012 standard + +\ Results from words that output to the user output device have to visually +\ checked for correctness. These are .R U.R .( + +\ ----------------------------------------------------------------------------- +\ Assumptions & dependencies: +\ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been +\ included prior to this file +\ - the Core word set available +\ ----------------------------------------------------------------------------- +TESTING Core Extension words + +DECIMAL + +TESTING TRUE FALSE + +T{ TRUE -> 0 INVERT }T +T{ FALSE -> 0 }T + +\ ----------------------------------------------------------------------------- +TESTING <> U> (contributed by James Bowman) + +T{ 0 0 <> -> FALSE }T +T{ 1 1 <> -> FALSE }T +T{ -1 -1 <> -> FALSE }T +T{ 1 0 <> -> TRUE }T +T{ -1 0 <> -> TRUE }T +T{ 0 1 <> -> TRUE }T +T{ 0 -1 <> -> TRUE }T + +T{ 0 1 U> -> FALSE }T +T{ 1 2 U> -> FALSE }T +T{ 0 MID-UINT U> -> FALSE }T +T{ 0 MAX-UINT U> -> FALSE }T +T{ MID-UINT MAX-UINT U> -> FALSE }T +T{ 0 0 U> -> FALSE }T +T{ 1 1 U> -> FALSE }T +T{ 1 0 U> -> TRUE }T +T{ 2 1 U> -> TRUE }T +T{ MID-UINT 0 U> -> TRUE }T +T{ MAX-UINT 0 U> -> TRUE }T +T{ MAX-UINT MID-UINT U> -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING 0<> 0> (contributed by James Bowman) + +T{ 0 0<> -> FALSE }T +T{ 1 0<> -> TRUE }T +T{ 2 0<> -> TRUE }T +T{ -1 0<> -> TRUE }T +T{ MAX-UINT 0<> -> TRUE }T +T{ MIN-INT 0<> -> TRUE }T +T{ MAX-INT 0<> -> TRUE }T + +T{ 0 0> -> FALSE }T +T{ -1 0> -> FALSE }T +T{ MIN-INT 0> -> FALSE }T +T{ 1 0> -> TRUE }T +T{ MAX-INT 0> -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING NIP TUCK ROLL PICK (contributed by James Bowman) + +T{ 1 2 NIP -> 2 }T +T{ 1 2 3 NIP -> 1 3 }T + +T{ 1 2 TUCK -> 2 1 2 }T +T{ 1 2 3 TUCK -> 1 3 2 3 }T + +T{ : RO5 100 200 300 400 500 ; -> }T +\ T{ RO5 3 ROLL -> 100 300 400 500 200 }T +\ T{ RO5 2 ROLL -> RO5 ROT }T +\ T{ RO5 1 ROLL -> RO5 SWAP }T +\ T{ RO5 0 ROLL -> RO5 }T + +T{ RO5 2 PICK -> 100 200 300 400 500 300 }T +T{ RO5 1 PICK -> RO5 OVER }T +T{ RO5 0 PICK -> RO5 DUP }T + +\ ----------------------------------------------------------------------------- +TESTING 2>R 2R@ 2R> (contributed by James Bowman) + +T{ : RR0 2>R 100 R> R> ; -> }T +T{ 300 400 RR0 -> 100 400 300 }T +T{ 200 300 400 RR0 -> 200 100 400 300 }T + +T{ : RR1 2>R 100 2R@ R> R> ; -> }T +T{ 300 400 RR1 -> 100 300 400 400 300 }T +T{ 200 300 400 RR1 -> 200 100 300 400 400 300 }T + +T{ : RR2 2>R 100 2R> ; -> }T +T{ 300 400 RR2 -> 100 300 400 }T +T{ 200 300 400 RR2 -> 200 100 300 400 }T + +\ ----------------------------------------------------------------------------- +TESTING HEX (contributed by James Bowman) + +T{ BASE @ HEX BASE @ DECIMAL BASE @ - SWAP BASE ! -> 6 }T + +\ ----------------------------------------------------------------------------- +TESTING WITHIN (contributed by James Bowman) + +T{ 0 0 0 WITHIN -> FALSE }T +T{ 0 0 MID-UINT WITHIN -> TRUE }T +T{ 0 0 MID-UINT+1 WITHIN -> TRUE }T +T{ 0 0 MAX-UINT WITHIN -> TRUE }T +T{ 0 MID-UINT 0 WITHIN -> FALSE }T +T{ 0 MID-UINT MID-UINT WITHIN -> FALSE }T +T{ 0 MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ 0 MID-UINT MAX-UINT WITHIN -> FALSE }T +T{ 0 MID-UINT+1 0 WITHIN -> FALSE }T +T{ 0 MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ 0 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ 0 MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ 0 MAX-UINT 0 WITHIN -> FALSE }T +T{ 0 MAX-UINT MID-UINT WITHIN -> TRUE }T +T{ 0 MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ 0 MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT 0 0 WITHIN -> FALSE }T +T{ MID-UINT 0 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT 0 MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT 0 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT MID-UINT 0 WITHIN -> TRUE }T +T{ MID-UINT MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MID-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT MID-UINT MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT MID-UINT+1 0 WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT 0 WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 0 0 WITHIN -> FALSE }T +T{ MID-UINT+1 0 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 0 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 0 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT 0 WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 0 WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT+1 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MAX-UINT 0 WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT 0 0 WITHIN -> FALSE }T +T{ MAX-UINT 0 MID-UINT WITHIN -> FALSE }T +T{ MAX-UINT 0 MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT 0 MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT 0 WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT+1 0 WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MAX-UINT 0 WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MID-UINT WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T + +T{ MIN-INT MIN-INT MIN-INT WITHIN -> FALSE }T +T{ MIN-INT MIN-INT 0 WITHIN -> TRUE }T +T{ MIN-INT MIN-INT 1 WITHIN -> TRUE }T +T{ MIN-INT MIN-INT MAX-INT WITHIN -> TRUE }T +T{ MIN-INT 0 MIN-INT WITHIN -> FALSE }T +T{ MIN-INT 0 0 WITHIN -> FALSE }T +T{ MIN-INT 0 1 WITHIN -> FALSE }T +T{ MIN-INT 0 MAX-INT WITHIN -> FALSE }T +T{ MIN-INT 1 MIN-INT WITHIN -> FALSE }T +T{ MIN-INT 1 0 WITHIN -> TRUE }T +T{ MIN-INT 1 1 WITHIN -> FALSE }T +T{ MIN-INT 1 MAX-INT WITHIN -> FALSE }T +T{ MIN-INT MAX-INT MIN-INT WITHIN -> FALSE }T +T{ MIN-INT MAX-INT 0 WITHIN -> TRUE }T +T{ MIN-INT MAX-INT 1 WITHIN -> TRUE }T +T{ MIN-INT MAX-INT MAX-INT WITHIN -> FALSE }T +T{ 0 MIN-INT MIN-INT WITHIN -> FALSE }T +T{ 0 MIN-INT 0 WITHIN -> FALSE }T +T{ 0 MIN-INT 1 WITHIN -> TRUE }T +T{ 0 MIN-INT MAX-INT WITHIN -> TRUE }T +T{ 0 0 MIN-INT WITHIN -> TRUE }T +T{ 0 0 0 WITHIN -> FALSE }T +T{ 0 0 1 WITHIN -> TRUE }T +T{ 0 0 MAX-INT WITHIN -> TRUE }T +T{ 0 1 MIN-INT WITHIN -> FALSE }T +T{ 0 1 0 WITHIN -> FALSE }T +T{ 0 1 1 WITHIN -> FALSE }T +T{ 0 1 MAX-INT WITHIN -> FALSE }T +T{ 0 MAX-INT MIN-INT WITHIN -> FALSE }T +T{ 0 MAX-INT 0 WITHIN -> FALSE }T +T{ 0 MAX-INT 1 WITHIN -> TRUE }T +T{ 0 MAX-INT MAX-INT WITHIN -> FALSE }T +T{ 1 MIN-INT MIN-INT WITHIN -> FALSE }T +T{ 1 MIN-INT 0 WITHIN -> FALSE }T +T{ 1 MIN-INT 1 WITHIN -> FALSE }T +T{ 1 MIN-INT MAX-INT WITHIN -> TRUE }T +T{ 1 0 MIN-INT WITHIN -> TRUE }T +T{ 1 0 0 WITHIN -> FALSE }T +T{ 1 0 1 WITHIN -> FALSE }T +T{ 1 0 MAX-INT WITHIN -> TRUE }T +T{ 1 1 MIN-INT WITHIN -> TRUE }T +T{ 1 1 0 WITHIN -> TRUE }T +T{ 1 1 1 WITHIN -> FALSE }T +T{ 1 1 MAX-INT WITHIN -> TRUE }T +T{ 1 MAX-INT MIN-INT WITHIN -> FALSE }T +T{ 1 MAX-INT 0 WITHIN -> FALSE }T +T{ 1 MAX-INT 1 WITHIN -> FALSE }T +T{ 1 MAX-INT MAX-INT WITHIN -> FALSE }T +T{ MAX-INT MIN-INT MIN-INT WITHIN -> FALSE }T +T{ MAX-INT MIN-INT 0 WITHIN -> FALSE }T +T{ MAX-INT MIN-INT 1 WITHIN -> FALSE }T +T{ MAX-INT MIN-INT MAX-INT WITHIN -> FALSE }T +T{ MAX-INT 0 MIN-INT WITHIN -> TRUE }T +T{ MAX-INT 0 0 WITHIN -> FALSE }T +T{ MAX-INT 0 1 WITHIN -> FALSE }T +T{ MAX-INT 0 MAX-INT WITHIN -> FALSE }T +T{ MAX-INT 1 MIN-INT WITHIN -> TRUE }T +T{ MAX-INT 1 0 WITHIN -> TRUE }T +T{ MAX-INT 1 1 WITHIN -> FALSE }T +T{ MAX-INT 1 MAX-INT WITHIN -> FALSE }T +T{ MAX-INT MAX-INT MIN-INT WITHIN -> TRUE }T +T{ MAX-INT MAX-INT 0 WITHIN -> TRUE }T +T{ MAX-INT MAX-INT 1 WITHIN -> TRUE }T +T{ MAX-INT MAX-INT MAX-INT WITHIN -> FALSE }T + +\ ----------------------------------------------------------------------------- +\ TESTING UNUSED (contributed by James Bowman & Peter Knaggs) +\ +\ VARIABLE UNUSED0 +\ T{ UNUSED DROP -> }T +\ T{ ALIGN UNUSED UNUSED0 ! 0 , UNUSED CELL+ UNUSED0 @ = -> TRUE }T +\ T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = +\ -> TRUE }T \ aligned -> unaligned +\ T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = -> TRUE }T \ unaligned -> ? +\ +\ ----------------------------------------------------------------------------- +TESTING AGAIN (contributed by James Bowman) + +T{ : AG0 701 BEGIN DUP 7 MOD 0= IF EXIT THEN 1+ AGAIN ; -> }T +T{ AG0 -> 707 }T + +\ ----------------------------------------------------------------------------- +\ TESTING MARKER (contributed by James Bowman) +\ +\ 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 +\ +\ ----------------------------------------------------------------------------- +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 + +\ Additional tests on the the ANS Forth Core word set + +\ This program was written by Gerry Jackson in 2007, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct + +\ ------------------------------------------------------------------------------ +\ The tests are based on John Hayes test program for the core word set +\ +\ This file provides some more tests on Core words where the original Hayes +\ tests are thought to be incomplete +\ +\ Words tested in this file are: +\ DO I +LOOP RECURSE ELSE >IN IMMEDIATE FIND IF...BEGIN...REPEAT ALLOT DOES> +\ and +\ Parsing behaviour +\ Number prefixes # $ % and 'A' character input +\ Definition names +\ ------------------------------------------------------------------------------ +\ Assumptions and dependencies: +\ - tester.fr or ttester.fs has been loaded prior to this file +\ - core.fr has been loaded so that constants MAX-INT, MIN-INT and +\ MAX-UINT are defined +\ ------------------------------------------------------------------------------ + +DECIMAL + +TESTING DO +LOOP with run-time increment, negative increment, infinite loop +\ Contributed by Reinhold Straub + +VARIABLE ITERATIONS +VARIABLE INCREMENT +: GD7 ( LIMIT START INCREMENT -- ) + INCREMENT ! + 0 ITERATIONS ! + DO + 1 ITERATIONS +! + I + ITERATIONS @ 6 = IF LEAVE THEN + INCREMENT @ + +LOOP ITERATIONS @ +; + +T{ 4 4 -1 GD7 -> 4 1 }T +T{ 1 4 -1 GD7 -> 4 3 2 1 4 }T +T{ 4 1 -1 GD7 -> 1 0 -1 -2 -3 -4 6 }T +T{ 4 1 0 GD7 -> 1 1 1 1 1 1 6 }T +T{ 0 0 0 GD7 -> 0 0 0 0 0 0 6 }T +T{ 1 4 0 GD7 -> 4 4 4 4 4 4 6 }T +T{ 1 4 1 GD7 -> 4 5 6 7 8 9 6 }T +T{ 4 1 1 GD7 -> 1 2 3 3 }T +T{ 4 4 1 GD7 -> 4 5 6 7 8 9 6 }T +T{ 2 -1 -1 GD7 -> -1 -2 -3 -4 -5 -6 6 }T +T{ -1 2 -1 GD7 -> 2 1 0 -1 4 }T +T{ 2 -1 0 GD7 -> -1 -1 -1 -1 -1 -1 6 }T +T{ -1 2 0 GD7 -> 2 2 2 2 2 2 6 }T +T{ -1 2 1 GD7 -> 2 3 4 5 6 7 6 }T +T{ 2 -1 1 GD7 -> -1 0 1 3 }T +T{ -20 30 -10 GD7 -> 30 20 10 0 -10 -20 6 }T +T{ -20 31 -10 GD7 -> 31 21 11 1 -9 -19 6 }T +T{ -20 29 -10 GD7 -> 29 19 9 -1 -11 5 }T + +\ ------------------------------------------------------------------------------ +TESTING DO +LOOP with large and small increments + +\ Contributed by Andrew Haley + +MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP +USTEP NEGATE CONSTANT -USTEP +MAX-INT 7 RSHIFT 1+ CONSTANT STEP +STEP NEGATE CONSTANT -STEP + +VARIABLE BUMP + +T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; -> }T + +T{ 0 MAX-UINT 0 USTEP GD8 -> 256 }T +T{ 0 0 MAX-UINT -USTEP GD8 -> 256 }T + +T{ 0 MAX-INT MIN-INT STEP GD8 -> 256 }T +T{ 0 MIN-INT MAX-INT -STEP GD8 -> 256 }T + +\ Two's complement arithmetic, wraps around modulo wordsize +\ Only tested if the Forth system does wrap around, use of conditional +\ compilation deliberately avoided + +MAX-INT 1+ MIN-INT = CONSTANT +WRAP? +MIN-INT 1- MAX-INT = CONSTANT -WRAP? +MAX-UINT 1+ 0= CONSTANT +UWRAP? +0 1- MAX-UINT = CONSTANT -UWRAP? + +: GD9 ( n limit start step f result -- ) + >R IF GD8 ELSE 2DROP 2DROP R@ THEN -> R> }T +; + +T{ 0 0 0 USTEP +UWRAP? 256 GD9 +T{ 0 0 0 -USTEP -UWRAP? 1 GD9 +T{ 0 MIN-INT MAX-INT STEP +WRAP? 1 GD9 +T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9 + +\ ------------------------------------------------------------------------------ +TESTING DO +LOOP with maximum and minimum increments + +: (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ; +(-MI) CONSTANT -MAX-INT + +T{ 0 1 0 MAX-INT GD8 -> 1 }T +T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8 -> 2 }T + +T{ 0 MAX-INT 0 MAX-INT GD8 -> 1 }T +T{ 0 MAX-INT 1 MAX-INT GD8 -> 1 }T +T{ 0 MAX-INT -1 MAX-INT GD8 -> 2 }T +T{ 0 MAX-INT DUP 1- MAX-INT GD8 -> 1 }T + +T{ 0 MIN-INT 1+ 0 MIN-INT GD8 -> 1 }T +T{ 0 MIN-INT 1+ -1 MIN-INT GD8 -> 1 }T +T{ 0 MIN-INT 1+ 1 MIN-INT GD8 -> 2 }T +T{ 0 MIN-INT 1+ DUP MIN-INT GD8 -> 1 }T + +\ ------------------------------------------------------------------------------ +\ TESTING +LOOP setting I to an arbitrary value + +\ The specification for +LOOP permits the loop index I to be set to any value +\ including a value outside the range given to the corresponding DO. + +\ SET-I is a helper to set I in a DO ... +LOOP to a given value +\ n2 is the value of I in a DO ... +LOOP +\ n3 is a test value +\ If n2=n3 then return n1-n2 else return 1 +: SET-I ( n1 n2 n3 -- n1-n2 | 1 ) + OVER = IF - ELSE 2DROP 1 THEN +; + +: -SET-I ( n1 n2 n3 -- n1-n2 | -1 ) + SET-I DUP 1 = IF NEGATE THEN +; + +: PL1 20 1 DO I 18 I 3 SET-I +LOOP ; +T{ PL1 -> 1 2 3 18 19 }T +: PL2 20 1 DO I 20 I 2 SET-I +LOOP ; +T{ PL2 -> 1 2 }T +: PL3 20 5 DO I 19 I 2 SET-I DUP 1 = IF DROP 0 I 6 SET-I THEN +LOOP ; +T{ PL3 -> 5 6 0 1 2 19 }T +: PL4 20 1 DO I MAX-INT I 4 SET-I +LOOP ; +T{ PL4 -> 1 2 3 4 }T +: PL5 -20 -1 DO I -19 I -3 -SET-I +LOOP ; +T{ PL5 -> -1 -2 -3 -19 -20 }T +: PL6 -20 -1 DO I -21 I -4 -SET-I +LOOP ; +T{ PL6 -> -1 -2 -3 -4 }T +: PL7 -20 -1 DO I MIN-INT I -5 -SET-I +LOOP ; +T{ PL7 -> -1 -2 -3 -4 -5 }T +: PL8 -20 -5 DO I -20 I -2 -SET-I DUP -1 = IF DROP 0 I -6 -SET-I THEN +LOOP ; +T{ PL8 -> -5 -6 0 -1 -2 -20 }T + +\ ------------------------------------------------------------------------------ +TESTING multiple RECURSEs in one colon definition + +: ACK ( m n -- u ) \ Ackermann function, from Rosetta Code + OVER 0= IF NIP 1+ EXIT THEN \ ack(0, n) = n+1 + SWAP 1- SWAP ( -- m-1 n ) + DUP 0= IF 1+ RECURSE EXIT THEN \ ack(m, 0) = ack(m-1, 1) + 1- OVER 1+ SWAP RECURSE RECURSE \ ack(m, n) = ack(m-1, ack(m,n-1)) +; + +T{ 0 0 ACK -> 1 }T +T{ 3 0 ACK -> 5 }T +T{ 2 4 ACK -> 11 }T + +\ ------------------------------------------------------------------------------ +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 +\ +\ ------------------------------------------------------------------------------ +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 @ = -> }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 @ = -> }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 -> }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 = -> }T +T{ HERE 0 ALLOT HERE = -> }T + +\ ------------------------------------------------------------------------------ + +CR .( End of additional Core tests) CR + + + +\ To test the ANS Forth String word set + +\ This program was written by Gerry Jackson in 2006, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct + +\ ------------------------------------------------------------------------------ +\ Version 0.13 13 Nov 2015 Interpretive use of S" replaced by $" from +\ utilities.fth +\ 0.11 25 April 2015 Tests for REPLACES SUBSTITUTE UNESCAPE added +\ 0.6 1 April 2012 Tests placed in the public domain. +\ 0.5 29 April 2010 Added tests for SEARCH and COMPARE with +\ all strings zero length (suggested by Krishna Myneni). +\ SLITERAL test amended in line with comp.lang.forth +\ discussion +\ 0.4 30 November 2009 and replaced with TRUE +\ and FALSE +\ 0.3 6 March 2009 { and } replaced with T{ and }T +\ 0.2 20 April 2007 ANS Forth words changed to upper case +\ 0.1 Oct 2006 First version released + +\ ------------------------------------------------------------------------------ +\ The tests are based on John Hayes test program for the core word set +\ and requires those files to have been loaded + +\ Words tested in this file are: +\ -TRAILING /STRING BLANK CMOVE CMOVE> COMPARE SEARCH SLITERAL +\ REPLACES SUBSTITUTE UNESCAPE +\ +\ ------------------------------------------------------------------------------ +\ Assumptions, dependencies and notes: +\ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been +\ included prior to this file +\ - the Core word set is available and tested +\ - COMPARE is case sensitive +\ ------------------------------------------------------------------------------ + +TESTING String word set + +DECIMAL + +T{ : S1 S" abcdefghijklmnopqrstuvwxyz" ; -> }T +T{ : S2 S" abc" ; -> }T +T{ : S3 S" jklmn" ; -> }T +T{ : S4 S" z" ; -> }T +T{ : S5 S" mnoq" ; -> }T +T{ : S6 S" 12345" ; -> }T +T{ : S7 S" " ; -> }T +T{ : S8 S" abc " ; -> }T +T{ : S9 S" " ; -> }T +T{ : S10 S" a " ; -> }T + +\ ------------------------------------------------------------------------------ +TESTING -TRAILING + +T{ S1 -TRAILING -> S1 }T +T{ S8 -TRAILING -> S8 2 - }T +T{ S7 -TRAILING -> S7 }T +T{ S9 -TRAILING -> S9 DROP 0 }T +T{ S10 -TRAILING -> S10 1- }T + +\ ------------------------------------------------------------------------------ +TESTING /STRING + +T{ S1 5 /STRING -> S1 SWAP 5 + SWAP 5 - }T +T{ S1 10 /STRING -4 /STRING -> S1 6 /STRING }T +T{ S1 0 /STRING -> S1 }T + +\ ------------------------------------------------------------------------------ +TESTING SEARCH + +T{ S1 S2 SEARCH -> S1 TRUE }T +T{ S1 S3 SEARCH -> S1 9 /STRING TRUE }T +T{ S1 S4 SEARCH -> S1 25 /STRING TRUE }T +T{ S1 S5 SEARCH -> S1 FALSE }T +T{ S1 S6 SEARCH -> S1 FALSE }T +T{ S1 S7 SEARCH -> S1 TRUE }T +T{ S7 PAD 0 SEARCH -> S7 TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING ANS-COMPARE + +T{ S1 S1 ANS-COMPARE -> 0 }T +T{ S1 PAD SWAP CMOVE -> }T +T{ S1 PAD OVER ANS-COMPARE -> 0 }T +T{ S1 PAD 6 ANS-COMPARE -> 1 }T +T{ PAD 10 S1 ANS-COMPARE -> -1 }T +T{ S1 PAD 0 ANS-COMPARE -> 1 }T +T{ PAD 0 S1 ANS-COMPARE -> -1 }T +T{ S1 S6 ANS-COMPARE -> 1 }T +T{ S6 S1 ANS-COMPARE -> -1 }T +T{ S7 PAD 0 ANS-COMPARE -> 0 }T + +T{ S1 $" abdde" ANS-COMPARE -> -1 }T +T{ S1 $" abbde" ANS-COMPARE -> 1 }T +T{ S1 $" abcdf" ANS-COMPARE -> -1 }T +T{ S1 $" abcdee" ANS-COMPARE -> 1 }T + +: S11 S" 0abc" ; +: S12 S" 0aBc" ; + +T{ S11 S12 ANS-COMPARE -> 1 }T +T{ S12 S11 ANS-COMPARE -> -1 }T + +\ ------------------------------------------------------------------------------ +TESTING CMOVE and CMOVE> + +PAD 30 CHARS 0 FILL +T{ S1 PAD SWAP CMOVE -> }T +T{ S1 PAD S1 SWAP DROP COMPARE -> 0 }T +T{ S6 PAD 10 CHARS + SWAP CMOVE -> }T +T{ $" abcdefghij12345pqrstuvwxyz" PAD S1 SWAP DROP COMPARE -> 0 }T +T{ PAD 15 CHARS + PAD CHAR+ 6 CMOVE -> }T +T{ $" apqrstuhij12345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T +T{ PAD PAD 3 CHARS + 7 CMOVE -> }T +T{ $" apqapqapqa12345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T +T{ PAD PAD CHAR+ 10 CMOVE -> }T +T{ $" aaaaaaaaaaa2345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T +T{ S7 PAD 14 CHARS + SWAP CMOVE -> }T +T{ $" aaaaaaaaaaa2345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T + +PAD 30 CHARS 0 FILL + +T{ S1 PAD SWAP CMOVE> -> }T +T{ S1 PAD S1 SWAP DROP COMPARE -> 0 }T +T{ S6 PAD 10 CHARS + SWAP CMOVE> -> }T +T{ $" abcdefghij12345pqrstuvwxyz" PAD S1 SWAP DROP COMPARE -> 0 }T +T{ PAD 15 CHARS + PAD CHAR+ 6 CMOVE> -> }T +T{ $" apqrstuhij12345pqrstuvwxyz" PAD 26 COMPARE -> 0 }T +T{ PAD 13 CHARS + PAD 10 CHARS + 7 CMOVE> -> }T +T{ $" apqrstuhijtrstrstrstuvwxyz" PAD 26 COMPARE -> 0 }T +T{ PAD 12 CHARS + PAD 11 CHARS + 10 CMOVE> -> }T +T{ $" apqrstuhijtvvvvvvvvvvvwxyz" PAD 26 COMPARE -> 0 }T +T{ S7 PAD 14 CHARS + SWAP CMOVE> -> }T +T{ $" apqrstuhijtvvvvvvvvvvvwxyz" PAD 26 COMPARE -> 0 }T + +\ ------------------------------------------------------------------------------ +TESTING BLANK + +: S13 S" aaaaa a" ; \ Don't move this down as it might corrupt PAD + +T{ PAD 25 CHAR a FILL -> }T +T{ PAD 5 CHARS + 6 BLANK -> }T +T{ PAD 12 S13 COMPARE -> 0 }T + +\ ------------------------------------------------------------------------------ +TESTING SLITERAL + +T{ HERE DUP S1 DUP ALLOT ROT SWAP CMOVE S1 SWAP DROP 2CONSTANT S1A -> }T +T{ : S14 [ S1A ] SLITERAL ; -> }T +T{ S1A S14 COMPARE -> 0 }T +T{ S1A DROP S14 DROP = -> FALSE }T + +\ ------------------------------------------------------------------------------ +\ TESTING UNESCAPE +\ +\ CREATE SUBBUF 48 CHARS ALLOT +\ +\ \ $CHECK AND $CHECKN return f = 0 if caddr1 = SUBBUF and string1 = string2 +\ : $CHECK ( caddr1 u1 caddr2 u2 -- f ) 2SWAP OVER SUBBUF <> >R COMPARE R> or ; +\ : $CHECKN ( caddr1 u1 n caddr2 u2 -- f n ) ROT >R $CHECK R> ; +\ +\ T{ 123 SUBBUF C! $" " SUBBUF UNESCAPE SUBBUF 0 $CHECK -> FALSE }T +\ T{ SUBBUF C@ -> 123 }T +\ T{ $" unchanged" SUBBUF UNESCAPE $" unchanged" $CHECK -> FALSE }T +\ T{ $" %" SUBBUF UNESCAPE $" %%" $CHECK -> FALSE }T +\ T{ $" %%%" SUBBUF UNESCAPE $" %%%%%%" $CHECK -> FALSE }T +\ T{ $" abc%def" SUBBUF UNESCAPE $" abc%%def" $CHECK -> FALSE }T +\ T{ : TEST-UNESCAPE S" %abc%def%%ghi%" SUBBUF UNESCAPE ; -> }T \ Compile check +\ T{ TEST-UNESCAPE $" %%abc%%def%%%%ghi%%" $CHECK -> FALSE }T +\ +\ TESTING SUBSTITUTE REPLACES +\ +\ T{ $" abcdef" SUBBUF 20 SUBSTITUTE $" abcdef" $CHECKN -> FALSE 0 }T \ Unchanged +\ T{ $" " SUBBUF 20 SUBSTITUTE $" " $CHECKN -> FALSE 0 }T \ Zero length string +\ T{ $" %%" SUBBUF 20 SUBSTITUTE $" %" $CHECKN -> FALSE 0 }T \ %% --> % +\ T{ $" %%%%%%" SUBBUF 25 SUBSTITUTE $" %%%" $CHECKN -> FALSE 0 }T +\ T{ $" %%%%%%%" SUBBUF 25 SUBSTITUTE $" %%%%" $CHECKN -> FALSE 0 }T \ Odd no. %'s +\ +\ : MAC1 S" mac1" ; : MAC2 S" mac2" ; : MAC3 S" mac3" ; +\ +\ T{ $" wxyz" MAC1 REPLACES -> }T +\ T{ $" %mac1%" SUBBUF 20 SUBSTITUTE $" wxyz" $CHECKN -> FALSE 1 }T +\ T{ $" abc%mac1%d" SUBBUF 20 SUBSTITUTE $" abcwxyzd" $CHECKN -> FALSE 1 }T +\ T{ : SUBST SUBBUF 20 SUBSTITUTE ; -> }T \ Check it compiles +\ T{ $" defg%mac1%hi" SUBST $" defgwxyzhi" $CHECKN -> FALSE 1 }T +\ T{ $" 12" MAC2 REPLACES -> }T +\ T{ $" %mac1%mac2" SUBBUF 20 SUBSTITUTE $" wxyzmac2" $CHECKN -> FALSE 1 }T +\ T{ $" abc %mac2% def%mac1%gh" SUBBUF 20 SUBSTITUTE $" abc 12 defwxyzgh" $CHECKN +\ -> FALSE 2 }T +\ T{ : REPL ( caddr1 u1 "name" -- ) PARSE-NAME REPLACES ; -> }T +\ T{ $" " REPL MAC3 -> }T \ Check compiled version +\ T{ $" abc%mac3%def%mac1%gh" SUBBUF 20 SUBSTITUTE $" abcdefwxyzgh" $CHECKN +\ -> FALSE 2 }T \ Zero length string substituted +\ T{ $" %mac3%" SUBBUF 10 SUBSTITUTE $" " $CHECKN +\ -> FALSE 1 }T \ Zero length string substituted +\ T{ $" abc%%mac1%%%mac2%" SUBBUF 20 SUBSTITUTE $" abc%mac1%12" $CHECKN +\ -> FALSE 1 }T \ Check substitution is single pass +\ T{ $" %mac3%" MAC3 REPLACES -> }T +\ T{ $" a%mac3%b" SUBBUF 20 SUBSTITUTE $" a%mac3%b" $CHECKN +\ -> FALSE 1 }T \ Check non-recursive +\ T{ $" %%" MAC3 REPLACES -> }T +\ T{ $" abc%mac1%de%mac3%g%mac2%%%%mac1%hij" SUBBUF 30 SUBSTITUTE +\ $" abcwxyzde%%g12%wxyzhij" $CHECKN -> FALSE 4 }T +\ T{ $" ab%mac4%c" SUBBUF 20 SUBSTITUTE $" ab%mac4%c" $CHECKN +\ -> FALSE 0 }T \ Non-substitution name passed unchanged +\ T{ $" %mac2%%mac5%" SUBBUF 20 SUBSTITUTE $" 12%mac5%" $CHECKN +\ -> FALSE 1 }T \ Non-substitution name passed unchanged +\ T{ $" %mac5%" SUBBUF 20 SUBSTITUTE $" %mac5%" $CHECKN +\ -> FALSE 0 }T \ Non-substitution name passed unchanged +\ +\ \ Check UNESCAPE SUBSTITUTE leaves a string unchanged +\ T{ $" %mac1%" SUBBUF 30 CHARS + UNESCAPE SUBBUF 10 SUBSTITUTE $" %mac1%" $CHECKN +\ -> FALSE 0 }T +\ +\ \ Check with odd numbers of % characters, last is passed unchanged +\ T{ $" %" SUBBUF 10 SUBSTITUTE $" %" $CHECKN -> FALSE 0 }T +\ T{ $" %abc" SUBBUF 10 SUBSTITUTE $" %abc" $CHECKN -> FALSE 0 }T +\ T{ $" abc%" SUBBUF 10 SUBSTITUTE $" abc%" $CHECKN -> FALSE 0 }T +\ T{ $" abc%mac1" SUBBUF 10 SUBSTITUTE $" abc%mac1" $CHECKN -> FALSE 0 }T +\ T{ $" abc%mac1%d%%e%mac2%%mac3" SUBBUF 20 SUBSTITUTE +\ $" abcwxyzd%e12%mac3" $CHECKN -> FALSE 2 }T +\ +\ \ Check for errors +\ T{ $" abcd" SUBBUF 4 SUBSTITUTE $" abcd" $CHECKN -> FALSE 0 }T \ Just fits +\ T{ $" abcd" SUBBUF 3 SUBSTITUTE ROT ROT 2DROP 0< -> TRUE }T \ Just too long +\ T{ $" abcd" SUBBUF 0 SUBSTITUTE ROT ROT 2DROP 0< -> TRUE }T +\ T{ $" zyxwvutsr" MAC3 REPLACES -> }T +\ T{ $" abc%mac3%d" SUBBUF 10 SUBSTITUTE ROT ROT 2DROP 0< -> TRUE }T +\ +\ \ Conditional test for overlapping strings, including the case where +\ \ caddr1 = caddr2. If a system cannot handle overlapping strings it should +\ \ return n < 0 with (caddr2 u2) undefined. If it can handle them correctly +\ \ it should return the usual results for success. The following definitions +\ \ apply the appropriate tests depending on whether n < 0 or not. +\ \ The overlapping SUBSTITUTE tests: +\ \ succeed if SUBSTITUTE returns an error i.e. n<0 +\ \ fail if n is incorrect +\ \ fail if the result string is at the incorrect addresses +\ \ fail if the result string is incorrect +\ \ Note that variables are used to avoid complicated stack manipulations +\ +\ VARIABLE sdest \ Holds dest address for SUBSTITUTE +\ 20 constant ssize +\ 2VARIABLE $sresult VARIABLE #subst \ Hold output from SUBSTITUTE +\ +\ \ sinit set ups addresses and inputs for SUBSTITUTE and saves the +\ \ output destination for check-subst +\ \ srcn and destn are offsets into the substitution buffer subbuf +\ \ (caddr1 u1) is the input string for SUBSTITUTE +\ +\ : sinit ( caddr1 u1 srcn destn -- src u1 dest size ) +\ CHARS subbuf + sdest ! ( -- caddr1 u1 srcn ) +\ CHARS subbuf + 2DUP 2>R ( -- caddr1 u1 src ) ( R: -- u1 src ) +\ SWAP CHARS MOVE ( -- ) +\ R> R> sdest @ ssize ( -- src u1 dest size) ( R: -- ) +\ ; +\ +\ \ In check-subst +\ \ (caddr1 u1) is the expected result from SUBSTITUTE +\ \ n is the expected n if SUBSTITUTE succeeded with overlapping buffers +\ +\ : check-subst ( caddr1 u1 n -- f ) +\ #subst @ 0< +\ IF DROP 2DROP TRUE EXIT THEN \ SUBSTITUTE failed, test succeeds +\ #subst @ = >R +\ $sresult CELL+ @ sdest @ = R> AND +\ IF $sresult 2@ COMPARE 0= EXIT THEN +\ 2DROP FALSE \ Fails if #subst or result address is wrong +\ ; +\ +\ \ Testing the helpers sinit and check-subst +\ +\ T{ $" abcde" 2 6 sinit -> subbuf 2 chars + 5 subbuf 6 chars + ssize }T +\ T{ $" abcde" subbuf 2 chars + over compare -> 0 }T +\ T{ sdest @ -> subbuf 6 chars + }T +\ +\ T{ -78 #subst ! 0 0 0 check-subst -> TRUE }T +\ T{ 5 #subst ! $" def" over sdest ! 2dup $sresult 2! 5 check-subst -> TRUE }T +\ T{ 5 #subst ! $" def" over sdest ! 2dup $sresult 2! 4 check-subst -> FALSE }T +\ T{ 5 #subst ! $" def" over sdest ! 2dup 1+ $sresult 2! 5 check-subst -> FALSE }T +\ T{ 5 #subst ! $" def" over sdest ! 2dup 1- $sresult 2! 3 check-subst -> FALSE }T +\ +\ \ Testing overlapping SUBSTITUTE +\ +\ : do-subst ( caddr1 u1 n1 n2 -- ) +\ sinit SUBSTITUTE #subst ! $sresult 2! +\ ; +\ +\ T{ $" zyxwvut" MAC3 REPLACES -> }T +\ T{ $" zyx" MAC2 REPLACES -> }T +\ +\ T{ $" a%mac3%b" 0 9 do-subst $" azyxwvutb" 1 check-subst -> TRUE }T +\ T{ $" c%mac3%d" 0 3 do-subst $" czyxwvutd" 1 check-subst -> TRUE }T +\ T{ $" e%mac2%f" 0 3 do-subst $" ezyxf" 1 check-subst -> TRUE }T +\ T{ $" abcdefgh" 0 0 do-subst $" abcdefgh" 0 check-subst -> TRUE }T +\ T{ $" i%mac3%j" 3 0 do-subst $" izyxwvutj" 1 check-subst -> TRUE }T +\ T{ $" k%mac3%l" 9 0 do-subst $" kzyxwvutl" 1 check-subst -> TRUE }T +\ +\ \ Simulating a failing overlapping SUBSTITUTE +\ +\ T{ $" pqrst" 2dup 0 0 do-subst -78 #subst ! 0 check-subst -> TRUE }T +\ +\ \ Using SUBSTITUTE to define a name whose (caddr u) is on the stack +\ : $CREATE ( caddr u -- ) +\ S" name" REPLACES ( -- ) +\ S" CREATE %name%" SUBBUF 40 SUBSTITUTE +\ 0 > IF EVALUATE THEN +\ ; +\ t{ $" SUBST2" $CREATE 123 , -> }t +\ t{ SUBST2 @ -> 123 }t +\ +\ ------------------------------------------------------------------------------ + +\ STRING-ERRORS SET-ERROR-COUNT + +CR .( End of String word tests) CR + diff --git a/common/ansification.txt b/common/ansification.txt new file mode 100644 index 0000000..6b09007 --- /dev/null +++ b/common/ansification.txt @@ -0,0 +1,236 @@ + +\ ----------------------------------------------------------------------------- +\ Layer for ANS Forth compatibility and coverage +\ ----------------------------------------------------------------------------- + +\ Caveats, which cannot be rectified for technical reasons: + +\ create does> is only possible for compilation into RAM memory. +\ Use when compiling into Flash. +\ does> can be applied one time only. + +\ Flags like IMMEDIATE need to be placed inside the definitions. +\ In RAM, applying flags is possible in a standard way afterwards, +\ but the RA cores automatically apply INLINE when appropriate. If you +\ also apply IMMEDIATE after the definition is already finalised with ; +\ then this becomes IMMEDIATE+INLINE, which means compile-only. + +\ Using flash memory requires thinking twice sometimes. +\ Locations cannot be changed anymore, as many standard Forth tricks +\ are based on the assumption that all memory is writeable multiple times. + +\ Caveats, which are not implemented: + +\ '*' style numbers will not be recognised. + +\ ----------------------------------------------------------------------------- + +true variable ansification? + +: mecrisp-style ( -- ) false ansification? ! ; +: standard-style ( -- ) true ansification? ! ; + +: variable! ( n -- ) variable ; +: 2variable2! ( d -- ) 2variable ; + +: variable ( n -- ) ansification? @ if 0 then variable ; +: 2variable ( d -- ) ansification? @ if 0. then 2variable ; + +: invert ( x -- ~x ) not inline 1-foldable ; + +: literal ( x -- ) literal, immediate ; + +: char+ ( u -- u+1 ) 1+ inline 1-foldable ; +: chars ( u -- u ) inline 0-foldable ; + +: >body ( addr -- addr* ) begin dup 2 - h@ $4780 <> while 2 + repeat 1-foldable ; + +: .( ( -- ) [char] ) ['] ." $1E + call, parse string, immediate 0-foldable ; + +: :noname ( -- addr ) 0 s" : (noname)" evaluate drop here 2 - ; + +: 0> ( n -- ? ) 0 > 1-foldable ; + +: compile, ( addr -- ) call, ; + +: erase ( addr u -- ) 0 fill ; + +256 buffer: PAD + +: $" ( -- c-addr u ) [char] " parse ; + +: sliteral ( c-addr u -- ) ( -- c-addr u ) ['] s" $4 + call, string, immediate ; + +\ ----------------------------------------------------------------------------- +\ Tools taken from Swapforth by James Bowman +\ ----------------------------------------------------------------------------- + +\ Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2. +: sm/rem ( d1 n1 -- n2 n3 ) + 2dup xor >r \ combined sign, for quotient + over >r \ sign of dividend, for remainder + abs >r dabs r> + um/mod ( remainder quotient ) + swap r> 0< if negate then \ apply sign to remainder + swap r> 0< if negate then \ apply sign to quotient +3-foldable ; + +\ Divide d1 by n1, giving the floored quotient n3 and the remainder n2. +\ Adapted from hForth +: fm/mod ( d1 n1 -- n2 n3 ) + dup >r 2dup xor >r + >r dabs r@ abs + um/mod + r> 0< if + swap negate swap + then + r> 0< if + negate \ negative quotient + over if + r@ rot - swap 1- + then + then + r> drop +3-foldable ; + +256 buffer: BUF0 \ At least 33 characters required + +: word ( c -- c-addr ) + begin + source >r >in @ + c@ over = + r> >in @ xor and + while + 1 >in +! + repeat + + parse + dup BUF0 c! + BUF0 1+ swap move + BUF0 +; + +: /string dup >r - swap r> + swap ; + +: >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) + begin + dup + while + over c@ digit + 0= if drop exit then + >r 2swap base @ + tuck * >r um* r> + \ Inlined Swapforth ud* ( ud1 u -- ud2 ) + r> s>d d+ 2swap + 1 /string + repeat +; + +: within ( n1|u1 n2|u2 n3|u3 -- ? ) over - >r - r> u< ; + +: save-input ( -- xn ... x1 n ) + >in @ 1 +; + +: restore-input ( xn ... x1 n -- ? ) + drop >in ! + true +; + +: d.r ( d n -- ) + >r + dup >r dabs <# #s r> sign #> + r> over - spaces type +; + +: .r ( n1 n2 -- ) + >r s>d r> d.r +; + +: u.r ( u n -- ) + 0 swap d.r +; + +: bounds \ ( a u -- a+u a ) + over + swap +; + +: cmove \ ( addr1 addr2 u -- ) + bounds rot >r + begin + 2dup xor + while + r@ c@ over c! + r> 1+ >r + 1+ + repeat + r> drop 2drop +; + +: cmove> \ ( addr1 addr2 u -- ) + begin + dup + while + 1- >r + over r@ + c@ + over r@ + c! + r> + repeat + drop 2drop +; + +: same? ( c-addr1 c-addr2 u -- -1|0|1 ) + bounds ?do + i c@ over c@ - ?dup if + 0> 2* 1+ + nip unloop exit + then + 1+ + loop + drop 0 +; + +: compare-flag ( caddr-1 len-1 c-addr-2 len-2 -- ? ) compare ; + +: ans-compare ( caddr-1 len-1 c-addr-2 len-2 -- n ) + rot 2dup swap - >r \ ca1 ca2 u2 u1 r: u1-u2 + min same? ?dup + if r> drop exit then + r> dup if 0< 2* 1+ then ; + +: blank + bl fill +; + +: -trailing + begin + 2dup + 1- c@ bl = + over and + while + 1- + repeat +; + +\ Search the string specified by c-addr1 u1 for the string +\ specified by c-addr2 u2. If flag is true, a match was found +\ at c-addr3 with u3 characters remaining. If flag is false +\ there was no match and c-addr3 is c-addr1 and u3 is u1. + +: search ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag ) + dup 0= if \ special-case zero-length search + 2drop true exit + then + + 2>r 2dup + begin + dup + while + 2dup 2r@ ( c-addr1 u1 c-addr2 u2 ) + rot over min -rot ( c-addr1 min_u1_u2 c-addr2 u2 ) + compare 0= if + 2swap 2drop 2r> 2drop true exit + then + 1 /string + repeat + 2drop 2r> 2drop + false +; + diff --git a/linux-ra/mecrisp-stellaris-linux-with-disassembler-and-math b/linux-ra/mecrisp-stellaris-linux-with-disassembler-and-math index 4255cb8b56256466f5154eb8c254ecdf8b52256e..0e17b5766f57030a6b7fa1d3188a8f3357d67349 100755 GIT binary patch delta 11480 zcmZuX30#v$_A_4&4v|BY!w3YzDTG4=Paqs}D2hitQ6YptqCg@6#A*$+^=fUkj@#|E zZrknlZr4_@$HJ~#-QF!=TWhavZ2MQ+ZoAP{zTDsc%_KqX|NrARVdlLzZ{ECl^X9#o z@54WEPaWe9S8&PZS1K=t;kiT^uEl!^2~Wh`WH9`X_(!rjq8{HvUWtf~j&ucCq!|ID zRW@;Z#Z_s`dnmM=vzo}a5&8I65;>*3@B4C)(#3N*lws~uu^>5CAVT9C` z7+IXP_k<7>hJWQ5ErbwRmpkWK?j?`lq zD>4snAQ4k@BxN2veDK7gsjpzky$+Fe4{=UQ!7EQBM*WEK{U;{Htdigpq#>>w_n!DH zE&=1qb z4&FpQO02@`$h4#k+;yTP=`L=@cXn#w)3oY;0t@#O8Vrz2|)u@7_mZ> z$~_SW>>mElcEr{p6xN}MoK`CEc?!zoP#%Ng9XJtjC=7i~O7k^% z68Up}0sbTTDt{^7MKWe@oxBT{`XQh_4COL;Vs?yZBz%m#H9Kp8E18bLX*v-a1Tk$m z7!8M}Fj!L?qS}(D8mp2RL}D_kHCit$^fDZk$egXQWCkN4@Qhw2e|J$~leOz`DdafD`QoIxt zXm-$AQYyAS>O$6cV9kOD07Bj=h@Rx}_Ru7uhsloxvPtQwjDsl&9VTIg30OsP3ZqNc z0TlH~G+jH4S~Mu|R|I4Yu%Y2T1{X6h9>ic=-Yq8W75F>cI2RZ5W2zB6{3iKBq0-#w zM(NfufzJ~HhTmsBMY?QL!eCQvsO3v! zx*9XuLlL$<=N9-ff!icUqM@|Hs>R`rC?j~Zl9bGeHY)|G{I!!f<>#Q^IybXS0baAxeM+x8@20A0Y&lHaB-_O{V#Bs%n8Z0#qtUYxNy4x|f?y z;I#mCdIBoj)U7_sllujJ13;}FX}Q7NtOerZamZRCP&QH|@U?*a&Ldr>Zl^c~Efn}f zfPU_w!v_kvNHsD%N>{&&2`KIE=r(DanN9vAOs>Yd$%`K-LuW&l^-QO`bqH4cB9su& z_tO{jN-pMHslyRfOm%~(_Us8?K2YzddA%B>k zCXECh^E1i&^QX(sGJCHa7q3Cq4_RHBD)1YHz~Lq$%%5hyEBDk@jQXnRRQ`4aOVRMl zFu1%=(rnP0ip$1-i#JYCerwYuN9w+{HBSxFaq>VF8s+l1ya=$hW+Ac>S>Fe@Wn~iy zSlHC9Z=;5Stj{=+HNwNmr7G2kc(ke#hAm7**6mERCE&i0bsMV(1JvR`!!BU4yiZi0 zwn=1}nnm>jE)2GLs~uVIa#O9K;l<>O1+0$$E%8wOv`v zV3v%dH38q90cdWYSlg@bLjS$=HERWQYBk-RCgzsjT~?^Oc<~y*`}-uOE_D}!o>^wB z0tb(zN+!joQ`IQ(y>i@Wtcn6icpt7G0tjsvdMW0kxr47)2Y@cFIR>jSpiVLZG&}$V zx%=?~GBM;niz9UrusDCRfw>NY-LWII?i#8Lw8(RrbS78*7{jq&W7THzOGzT$Pr_6gc!fRP8lIm=Mpe`CljLVrD|V4prHZ)@ z`y}whCY`*cyR9u4TODuE5f8+aEuNx#pe*ncf&bASv{K#f$N%&OwR8C_@^WbsS3QfI zElq_W$6lJip?osEtOA11hO&$dzuTk=q4o1nD)e3@1R{(^q5UBgD|w|%hU>^jWwCfM zxm2cz%!T2!&Ds{QTsfSdc7abLapjq~mDH54%?q5(mZwMEsh==ioEmA7GkDM}Kff+mFFj(u!Su%bjh_HhVE9Kd}ZlUnCL67<3>sq3g=55NvTju%y1~ylC>2}f_@J> zF&QER3wfbpPHDye)4S}Z-WKMzsNo9y3E=T5ixI1@s-grw7TOnyVo^!%9N>AzMb93; zZu~|;jmNK_;zn@^SGc<}w2&NGl*LsSl2eQ3;@gRRQC{T1LOORbXr>uugGukJe3led zMoUiuykZX7P?(A*>UQx9T`s-^N|~!)m!5&gTzn}&3z&M!#*s9L3x#v>Q>Tl!LWu?C z+(y2r&Wtn8^Lptv6Wz_oT4;0e4}v1U2NQmqB-X@DS>kr{g1dhUf^3ExaPeO|$?}?1 znT2(fsC8O(GYw93OdXO`H0&S`)WoJ0&j-ePCEIm+@OprMO>pt$GInr z&cac++)J&e)Tsy#BNo-FuF9n@{v1$02h@~y2x#vocu7&@|8?+RM>+S2HEOp0F22Rd)Ranp13{&`8D3Ok zXfad=S#a^mQq_pDs-l=lYG^@QsspppXyrxl)4uTE!*7CM@h{B4qD2)FJ zlyi2O7*I9x!=;x=>GDMU z1JNum;KZfmk>&BNGfLT(G{NzLP&WRQ>P4CQ@uge_=M=@LzFOLgbLWB&uVye&i(*yy zpgb9ZXd7PW919=b;-zg-_*Q%=Y-<;6(m3e|ZV9Sbrg$*13aU*QV%@5|0&4M=6cD!?}a!Ym0of&uUQ$ zg?&P{txUsVfvR;Tkfkjf?M?Pd!1-FY>*z! z`A{B#Km;yw&PwH_Vnltikn+Ae+xm_I0_WkzFd%+_5ha{IT#e_&vAd2?I1!9Y z9O-@!zm?T0q1M7`d!eTGNOSSLU&g3@O0OcRhkx50#_k|gsUH3m)X^ZdcMqRMF04v3 zKgRSKsO?d=bwjWWE92(J1w4WWR0FD!Eg%6mKqF%}|1XHqDHsD|*6xMVJ1 z#=vHtT13|+NZ-+=?KDEnjs`bY?<<@1g@?b>7S7UFd3Q&%wzH+puss-=Evo?=eAZ*; zO|~#E+R)>}ZnFsdIneJl7s}?wyf*@KS@=hX6ZpT|sH>xzL^EY$b9H&h#a{!%nd|n# z-eQxN`qsS(DAW~{0tTUIA+LLSIZ8zIbWjI1eb3}q*~ zn_mDjtr6V(*MdZD*qR-D{n8M)N_zE1gUcA-eGI$&s)=BM=iT5jXpBYESL#9Noy`FG zarNr*%djb~J4E|c`;k~w{>$_zOCN|FIU1&jRUJU>(~rk__;Wz>y*E$vg%4EpP|(gd zfcZ1&UsDjbMkrjW)pY7jM&+t5ZCe{eVI~NtD8XU`>{tVz)>W`}#!GTK)RCUZmp zJ!ey!&UBVSs+x64-vPN7`WogzWu@}d6Y}QRZ~$bd@gY4ey|EHzu_B#+CtQ+!N;a)c zz*cg{S~$t7$s=oL;zsh%wTavn8@aqz4w#^IiFkx$u1ml#kR|I1@L|%wF1j$eh8o$V zj_&p*ZD$t?9|t}B2K)cbbpuBpMdLArIy79pn0&l$UG!USCs@CWPqEV+UJM()#pC3g zNzwY)p!WdxER?57!}>(C)IMHLX_A5FWq{u24jrkV{%R>Gq$sM=$v*|K!#-FUwT>bv zN~*3zAF z-xMvO{_$fX+fao6Le_6kNX|gdw@Ckn94>bWd38gQTJb%)=mdf@AiZJAje{Q&b~P-tBbqBc2s8}mT0*i8jEgVb%xfLoXyoAR)fys&8jciBTOZ<>)>m9xUjimNZW7AdhJaNmgsj^nEbp zA7D(lOVRcky;kls^UbZ<@aAz}Yvzm{;4qfhZy4%36Naj?A8D8x>);!KViv54*UqGD zQ@|}M!MY{zz_L`AgO89qbeR~F=X449pX5DV20lRk3%`$%IDHy8iADMvJe3^MFW`Q* zk!3o$$iWwr|LCXTkBMYU;-o0ZGOQ2^3Bqxbw5AL*CVFiIfv3yO+g$lbnolh! zzS70d04LoKP_dh8{0h4f7KB>p*WVY|tT(Am?aE~4#31DFIdwHr>b=?%gk6kxh>xa4 z+ojPVpfLiC8HseV{hW@Q#Wi{dGFAz~5bH46*TK})sqbj@bpU!w2c;;!k_tKoBAs*j zvC>BBxsPt5laX}5rFM3q6)s>0Y0Tv24^K?U+uzNb-*BNvkCmxL0wGpxc1h)OrLtHK zC-c)TWT9Q|hge57^8Ki4sO;*{D!A7b9V-ikywt@nbp?B=<=JU+B=CQs8Ltbc&9szV z4bj|8Id_86#3&yD%50#VW+^jYy?6^##RRE_k?sM~SRkds&~-k;W+v*+o=vrYQV|@p zK@JaZg}D4zDF24?6O;kSpjLqY5O1cM0Q$K%=&u0&Jd|@#$V2TR=8vKBA(Z!_9EFZ~ z&@qd36nAHLnAn6ZV&XzExKJFCBO~x6PP+$8YXt#AvwS@WFhoNoMgjncoT>JqT zsuLE=4g26F&=d#R64jEpfo$n0@Led}65?y020X++7XJ$U74VRaFnjD{ z6DOW+GvT2%qcexQO+z+xJ_%}bcgiAm-Qolwa3C3`QqE-~ZKj2RZ1=-vCdW;=lm7v$ zY3S)fVvCFaEBVDV4<93GU5Qgq8{*5~ZdHvyhJO`NcY)q+B^$funpGN`PN;vtmLib7)&5n@~!QO=N1) zMEaGG#is$FyJ^ydohH~sou(!c$UohNOH?CK*ZLw+CO7Khr;w8F46&1U38bw%9x6Wz z2O~w~_vy6nKz+rY8<=asSzqh>OW3 z_*Igi?J0OV$=M#u)%KFb+mktmhZwh~au+@1q3yZweZYI$)9@SQ%Jw|X;~qLOfp2Gl zfC!$cZgWOm>n%TVU0ye34B};mr@JW-aQP5K?DL3Whk2g@5x`1ZUix%K-+K$a4CoDH zPcMBpf2LOfS70CXroopI|LrZnaU^3$joIcFHEFl`&ELseq1~bNo4=F43~i0cZ~ji+ zLfaa@`8)aZ&~DfJ&ELt7LfhEpH-9JpF0^}0e(R^11hh4N>vwMEUk89r?>B!Ze;nFv zCcpX9^g`6ss`Z<{lYgAzyZq))Qv<+v`OTju7=YJO^QYl?-R*ISeoM}`V$paE2d}56 z>|T{M*2RO0x03sAPfPJrjmMmv;p7Flv3|^+kLt!xbw;XAT;Eq03Y3e;7q_S3Jc4&7 zCd%nJy>wydqMc*3`xx#0b%8(|PRe&C(wMPjXDauzi`>66ojd0uukTEz2DLKXx(&RZgPp*nmZ{qwSXv~ z*g_8NlBH~fKATX~wcTJp#~J0STPVlj0%kE8*(EbC^ifhvJ6u-?Jo6_gsimC*%9$>S zydG@LKhAeBj@%U@-z1mU>fu~ax5-hIRS?yqdVjcpINgyMv#cVHg_gc3K;TyaH<62j z2kb(41+TS55&a#L%)HY-3p(N>K=Z4Uj%Z?UK6GYJ!-zk?8A9hoCAHScK+>2I&4uu_(MRSq{2I9qzkeceeJOC2P~NA6yX(p zMaBH#0kY!GNVC~a_mYR#K)}Dl?%zwN*bdod7eN5)Qz$ z8vy6uVUM%^D{kq34bt4|Tl)X(uIhk|N*P=Pb2?l{c^C{4z+XLA) zkZ1bcyodi63_jzgz81E`k#;c%@81d@NX(sl5Lt1T%%@BNeAzK)Y7S%&IYA)R(aPSG9lQVA694nKu8-0O)7jO|CD_pHo zzRPz|VZrMh+pdiIp<;a2*oQ|B?pPKIt z1*94;-!8^i1boq;lV54~GoYEQz`x0osDmW#Ky>U=K&k2rSk+Loa`mc}bl`?-M|zA^ zLuBcJ=;@zMVAuJuHK{b04!ND|K2TV+>vk&sWYZ3l2EKq&YC5%QcnY9tv1-5xyPw@0 zf%ffu7Hq6@p1`5;7^KKI(l}>?Tsfdj2x0l&QQ)KMlPb1%g5|Ll5wl^=lcIY{B;UYW zik0-=6V1)tNglaJ74R|u1Ysk&a8G1J?{D&f{X}waO2A%-?;#~5dH3e5@zw?5-#e+W zL2L{q-1_*9=PrX^-2$(s*WbW9WEZ6k=+JJbU*r@*>Qy$r-uD4kupkJtcaf9#rouJ$ zH}^&t-OOOMkHLOm(BC(S4c64%(xPR~y5efrZ^RuSc?TmmRe~^H3>8HT2{?TugYOxb z7!n;wo8=exR$BOu1ZZ~vZO9!|WQpeg(2^$(M#hTG6e~8Vd+4JN{g}|nAAlRn7f*b2 zupYyQyBYWE=kIo%yxs?)W(Qo$KJB4b6d2CLm*C!teoY0;Y4;>5ViF7sju@_aT)fVto?bCMJ z-EJSQZNF~cyLJWJ?wY=~-EI4C7wEg)-I{K@+OO+&Q~t^gNyz=?oJ*+o`~QD>!aXx{ z=FFKhGiT1+`(LMo_Z|^Wt`y$8<%NoiQ|V&R$CzjXKuj8~g@Kq~(br+~v^v@dFHDP% zzv_>0tFpp}D!t0~l_RQ_cSv-(;8_C~rWMd3h@DvkCFUd*vs= zbJ`#7A|#@MlH--rNL3UiPvKu>RHgSc{(S)3Nw|Od0s1?b7Mn<)fb7^*dOxg*O%FR1 zB(CGo6>Fh5S8P6A0Mlm74@(MC*TS=_X1qYdntTe+4)D)Rr}NIH#r-#>EoY}BYzm{d z!>*Jry8i6PDXEmc23Kbn(Z^waY6|U#wW(Tq2==75sV;AuMlPG-AF2IR1HaJxlOBYd z)8eTe?oV4xOW^&qN}2~V=VZ~Evn6v53$xxF69!4HVK9R0VfVV|@;>vH?`Q?}jE}>Y zbK}@VbL;56upvE}9)b4sH0pr6(+9Ov#;GS_Tvi@wi7t;Trye>U6xWOsR1BGV=7;0Z zr+bt>4cd%a+6Rt|K5Brg85?LkRA%5A^dEzu8kg4Pd zlomA6Xn3Mv5q%8)TCkSRg{*~bQFE)N5d+dL!S+2ox-cPP$S_EBQ(eL!oL`vJBc!vL zgr-hH28gH8OCyPEh74=85~eea&R&_xAz==?vB@OEv=^&5OvPaiHab`FcS-a}wAeq4 zQ@FMvetoa1uE}id+(E+Jc22KkU8JU-y90*7!j0X;)yoKv&`icSOQ&)_DEI4GpXeCr zk$`eBWBDaw@_L2bIpm=#GQjXE)bLIpdzz!89(#az9)_0}rA8}toU&;SxxMOdm*AB} zaZ&clTp8$?Lk>ekVXCbH`=mFl$=223q=k$LEiUY~S9VOmo%`)3I*`{*GQ)>td||gF z9v!DkL|h?tJOgHxw0l(Ucd>p=jmquJ;CqwnAgKe@HPzMcB%e@MuZ}S*`XeiAAY6Y9BjToS7#VTXn&&KIwaX&_mVLo0BMs-LSXnw+jwomVcU zMORUXMPOVU+mkIRHS>xiNvdl}CRfNlTW7O_3`pW^3C+P1B}rnU6j9pT+-Y(+mTDLy zNj!|uXh~IL>A?B<^o3?g>_(_U3a_vlTPG;b9hby*gnEOja$BS=7*Wt1$##zM)q$~5vV z{(Ts_mR!Y9+Ez3_;tyXleiyts@OV*y;*qZf_`E24*%tp)mn0TTESRWl3}n;eZhMJe7-cJCjxl{IS;kf;xu&{tvN)^O}cipQbjy( zbEB>pRc;}kH~6zkCyDiv+NH~8Gpm|9O-84Qd+lOx*=S|nYa^8OR7S0~bG zdc&G+CP(rA!b8upsGj<{vE~cjZ8IXwf<|p1LqfigKMn1wS&D5So;NXw_4B#Hmp67< ztjr{c=Mg{gga-wU%3v5&@<3duBc66H;Tnu(#M8>3BN6(EkGNh#4(odrbs0Mp?$0EHqBt#yUwix*!)cwcXr!-<+Y_yuVCmD2qa0m2|Q=E_-m&*wjTu)G@d(@o=yNVMR zt(Nf%ug9;{-Rf?ZF^jIptkT`&z6G8yPV9L=#xK4eU#V+wzl|8ut8TJ&;Ffeaxv@t0 zBr!I~#9ldK-%C7y^Gf0!67eK@iR(K~AF*I^02YjEYH95-HB(KVp)f(YOmX)?*7V~(ic1gN#3Px&&S<}*GwW8UMzRYGk zkx;gJy7`_m^@ox;!xyp9*dD@Pe3|*mP(B1p=Lp_>m{X>s2~b^@Dx6sWyUSM67vQ&L zSy^n+tT9EfzrAenW?2bpLPfG?I8` zOcFOjdwDj!8-7{7HUFgoZcclRot8-pr@C185Qj%B2q9#hgu9=Cw3P*EUwWsmL-#aw z*t%NHnvJDvaiPz@L>m}YG#)_Pp=+f+>@c32>*2|jYa$*BNMa^th9|+la&f8c|1rAw zn$h3!Xva)h63-%!k9eM0HDZX9#1!m*2aZ)GdCQRJ+X0qshIDff*UyZC8BIt(#SO|5 zq41W9R~ErPR^3Cg)J!wUMZ3GTVjJ995wB`N_?1Ftdv|DTdhcJc3t=f%nm0SiW&zfceWE@OWiW!efiMJZ4j;9BE#}0Bo=PYzbVc3@*+c z4~WfyfY^#{cc9OlnMH>Kq6MKlxO&P)i7G;f#-sKle?Uw?s!~*r60)kZQ#3_#q_;Zc z!>!O85MMz>evQl63wx?lraQ*R#f)IzZh|)=p+6uh18}-pmwb{B3^STd#%7khn7KN_ zbj0-xd{v#8@jb&I3)^SL$jR_8N&&Hr-2m|UWqdZ_b5Qg`+UjJ*A6@I9WOZuP>*H*i zC_c?8Xj@%S(zuj~7iMfVS~_U%igurCY<7}&-d=edJh~=@Zh=?VBn$5?gTJkr zRaArlBOypU8^&s?Sn?`6L=B$7IT&Z?!sp8Dl{1#(Vh;(;HZ%e@{VK$!Kz>cZOfSbM zN)W{{1?z(180@bpnf4_vU=y|;6zveUqwr2m0X+=kH5om&U;raZK%9=P4#hR2O7^0# zf5KLSO^sX=R`C6AGV=Woho(+` zEM~3|=Crk$Iv9VAF3jzfVRj?tD=`B>@e5z*!T?v+6(%aHgoYUOQXMYiGB$Q6Ww*9M zSXH|M@1lomZ>L2tb^V^G-v*|hUx;7`-8x9w=#iXuE)lKu3U>px{n4(3yDP}-3mw41(y4*h;a+cRG z&O*T-m5^J5+Q7o+0iLDAk(fD=24N_OrweguCZ5e0K7-<2J$~YvI>65G0&Ks)bOozM zAE-2?<@Z+^5){43Hb(cyG@mw1McTVKP3mWNR?(sqp3X<3h#g!U)$yQc;ZGI# z)Xblb;nS|5DvuWZo2OZ&BSaMx-yWaJ>mAb!x}f+5cE|v8jG(v>^gqk!Sz2+k58_D+@2w!IVB zHn${xg4Qtt|M^*bmdne$k?D=hn>oD1oKMEZB#e(s#%0(W!$EP_8x(D@Y;*Fov%x&= z6hmHiG(ulQ=yqt`tX-lF+<%ExDVP<7wpd|zkc*8Wdw%o|8mzvQiSrP9%w%4$+ z7{SYESmj~aRu1c9rp4~Utm4C}KlM<$WwYus@=^HV;VrXMzre>I%8z+Z}&+MG+44!o9;BPbA? zoC(AZzH3vydK8AGee4iqI99r1DIi-=5vMo(W83V&M4F*NywzM?ASGl-~?+D7ig2~VR%42WD zIQ1z!zHL##`7u@q2pdul_Rk>&TS_^NOOoEJV&*obqpQ8q)am3ICq{1b7+$7f%JxLT zQw_T9+lsy)_luV?wb{VgDADil4f@5C!5=QE+0-k3?jZtrh$5+c)9k7b{o+-m{|MU$ z@Z$Eg^aW$1M})i-8RA2@DYLH`Ob+^7xnAmR7$`Hl01&sIZZ-JGz0 zpGM-Y>w+Vo~mcJh_~u9 zgeekyU!OE93t9SuKeBvvlBFjIOY4*H_ENGVA8V?6b}XWs;mI9YbOsC~WC194E)!-* zVAwfpl_j7+C*O`vekaZ?Nmc83^f2O0RGyx%N3NP&eskUBJ92;j?KeyA`ueZu+W-3g zd+)vX>@&|iqk%_v>V>2r4DC#c+v<;I8=8WR+Y#FyUGUyrnzWfbHp+HIxn<_{lewyN z!=PWB>i3IZLFulUSVrEuD`obdF>E*2GEpMAD6(M{hSYoSu6eWyT)XN@e~DZ5E1zF{ z1Y2BCwh|p$$^F;|-}P4V2ZZeyR}a!j1NMviVS7U*y$>F3NX^w>lSJ*h(!bX)KFdq0 znA`;AMSU1gKlY1SJV5%_!}krdQM*ybR4RfVfA55~#;o)|1=NGQu&M87^ZohaT za4my(;UVMv@YnD-lB648*qA2V=Y!MD32?emnUX!uEIk1oO=d%{VRJX=8}&Er#>3mj z2YWX{OQS|uJvo|w1y3|;x22#ExXQHuGwCCen2jo4F(!LkXmk9cI>4S;h+u!2LB0@R z^UoOi-`f}$08LXuVgz2(YNcz}GlCg|B;~+{rUJSgjyBDo_8~upLwoHPH^5s>MfgTT zYSJdg2jp#X;}j1iF#TXlLE&IovsTC+gNEjXQ))I-Qr4@q+FBRDS345JS&17X0=(M1 zojwVPCT-MhewmFLcl#VvoAmg)VITh5;R%ygcy0^4Ys#cc*#IHR59?ayP!H^BiKj+5 z(V|ay-^W%N%@1=~%t%~&vJd{!qMIJ>yJ3(l*vZ0+o~`V?Eud04-jSr1 z1-jD*uQeCKk=BH;v#5kS;L+At0sa46D;8~WLYM}hX$z=ed2EJg|#DZYTAoU&%*O3mn4%P2xeM7EnTZC) zshHA_;_J36W5FJA1Rp%uevdb^;}}Ao3k_KE;{XxyUt;?kwlA=KhV2tKjPz+UAY|&zH{=FjQR|=Tajur4^&q;-Fy|VS<2UtfBOZE7FYWXKX=qSndD(c ze0{>NE-xX}491ScszJX(!Oa#B5MM&Bowy@e zSQUF7wUdh%ET);~cETGS_>N&GsBCkDD?4GHZ4SOrU2Dt6O5%Roim7fN^T2{+w^mpqa28f7e4F{vL# zqA&OatPm%-r%d#HV}jL5V%#@O^hd^oRwq%rqbB;_As#DE+}tu@L+5jtDHsjeduwf%_!eJySxJZGt3?G)`~{xcP{DqxmRKAXkIg^=DWO#MoUxq zq?(U;6}HaKWs_>Yh4niMCe^&xt1#I*vqNeVJCI*4e^w8StNccnL$WD7%B!h>IQWnogC?TzZRbviVih3vmJ z{~NbqRJmzzv=Spm6u0vvFI?=Js|<)LFGTOv(Ggg*H-ml&JMi~iIEugL;Q77T^fY|F zHyx7?X>SU>1yc5<;W=1>zx80;mp-dnnuf0dtX55D9-oW-%G-BkA3U~iu8<|c+xv9F zObI;u@@N3kx-;mvP~DwR2jM_>YV4~)rVHj=YJ9a;fJp>S+no~oxt5v_r~{nb4gK}Dl!PskPgVk-7KOd(hBi}BcRa)ev~GeXvH3b}$G zs}_pJc1y?={Gv3jXtY~HuHY9%?C*7iT){8?hxMC6uHfG(UP6G`5^@Dh$*^yAgj~Td zev188Q^*zk;vmC2L$2T#|IF~tkSqAbR~g>Kbmf}k+-W>L303O zs|lZ<3DBG4u5_25y*gBzgws71P*|HgFaY*q?q?X@}D{zaWc)5?gM;$@j?TFh! z;;!6+$j0Z=U-x2HzsCZGr(4;ACwf3eY&ofLYWhNV7caJt>ATmth3?2NX5Wz`) zjSOS25yVrQjN>8$O4LN-#K9$rH{(bWfTUZJGDh$i2`&32PW<2g>xt`;7`Ne;j`Vg zSQ^8`q9=J%$2GL)Iju>iov1eADUP&tNEO=Xpg71gQ5DuI-bLKn2@c)mBs&(BvkLC+ zStQK!!=HL|LYyDI?gDn*=)5wmAwmJu^qs=nsCjCavWjp zWFv}k#E+h{v^EMyErb{PvW3|`__8lY2=~DahjK8zW~!A{q{eOsqhu0310@u z=3=Owj-y^0!*}144igl!G2i~p7;~7Q*o4ndjfEWMHE!^y#}t@BhIBpyDSiR}I+UD# z0>^}G_FM+2ICuh#PMxv)UZQ4(0??YO=4qQH*lo4?aW5S6E zCk~lyP;?;iDCmzQXMF4ZajE~sX)k!05I@pxMB0zRb|g9W&)3j;cCpPx(?61rpUe#& z$zVouWHIf6`A1W!32Kj~(VxMdquI0=9yyw&^oyBZc=u=~K1}z*=+PYN2ko&+`YE&> z(@uL!QdpeM;}gfWPjtbrj%gP^D=87`B<+|Lsqp0ViH|V|7CxKt0GA=Zrew_2 zWXO7%k7+ulUNWRo=3~OwF%yvDXqgc|M10~!c=pzEp}Y}1x5ibL?fx*Kypb7vi4bcb z*%8B`oTq$u+!b%*y%At2Z#;MP?%HcH%t&Wf1jSOHob_hH+T+QIp9Oi`#G>^5KA$*@ z-=$~>OLBXm?|5ua=!jxtvGH3Gdm|ncdnBK@E_iNMXy(JaPnD_ojTzt5BF+%>U}2MS z@^-WAUFk5HnnD*da+q;LX~=+2j1Kt3tl*D)l8@uN;7%wLhDn6>ujRx|v>4-OozSh3 zr8#Dj`OezU?=#4k-ToWKLLAsFO%i|4Zw?EQ#?Y(M@=twu$W`OFc#>2Dcb@O>PcM8zj@-vlGK8M42?dXXe4 z53t-g94i_v_->UEtsK$(Bqz>;9k-{4t8jJf_H*L)`4RH7B;5zE-yUD6;CEN1Q%N+k z0yFaMN51%dOowTo6+Z}IC9<;7l!@=0A|*-s+X0BaL#J0CWMmOdOhi2j5mM!~EH_WE z%md>c@maHeB3wP^z)CVXlbie}_og6c3*lfZm-Lc^S(U0bb(xAHYdHIsgCw diff --git a/mecrisp-stellaris-source/common/compiler.s b/mecrisp-stellaris-source/common/compiler.s index a3cd22a..aef8efa 100644 --- a/mecrisp-stellaris-source/common/compiler.s +++ b/mecrisp-stellaris-source/common/compiler.s @@ -256,7 +256,15 @@ retkomma: @ Write pop {pc} opcode ldr r1, [r0] @ Check fill level of datastack. cmp r1, psp beq 1f - Fehler_Quit " Stack not balanced." + + ldr r1, =stack_canary @ Stackintegrität prüfen. + cmp tos, r1 @ Check stack integrity. + bne 5f + + ldr tos, =dots+10 @ Fehlermeldung vorbereiten. + bl type @ Prepare error message. +5: Fehler_Quit " Stack not balanced." + 1: @ Stack balanced, ok diff --git a/mecrisp-stellaris-source/common/controlstructures.s b/mecrisp-stellaris-source/common/controlstructures.s index 9fd8015..d5cb405 100644 --- a/mecrisp-stellaris-source/common/controlstructures.s +++ b/mecrisp-stellaris-source/common/controlstructures.s @@ -125,6 +125,7 @@ here: @ Gibt den Dictionarypointer zurück @ ----------------------------------------------------------------------------- Wortbirne Flag_visible, "flashvar-here" @ ( -- a-addr ) Gives RAM management pointer +flashvarhere: @ ----------------------------------------------------------------------------- pushdatos ldr tos, =VariablenPointer diff --git a/mecrisp-stellaris-source/common/datastackandmacros.s b/mecrisp-stellaris-source/common/datastackandmacros.s index 6a5f6de..5f64ba7 100644 --- a/mecrisp-stellaris-source/common/datastackandmacros.s +++ b/mecrisp-stellaris-source/common/datastackandmacros.s @@ -351,13 +351,13 @@ psp .req r7 .ifdef registerallocator .macro Dictionary_Welcome - Wortbirne Flag_invisible, "--- Mecrisp-Stellaris RA 2.4.7 ---" + Wortbirne Flag_invisible, "--- Mecrisp-Stellaris RA 2.4.8 ---" .endm .macro welcome Meldung bl dotgaensefuesschen .byte 8f - 7f @ Compute length of name field. -7: .ascii "Mecrisp-Stellaris RA 2.4.7" +7: .ascii "Mecrisp-Stellaris RA 2.4.8" .ascii "\Meldung\n" 8: .p2align 1 .endm @@ -365,13 +365,13 @@ psp .req r7 .else .macro Dictionary_Welcome - Wortbirne Flag_invisible, "--- Mecrisp-Stellaris 2.4.7 ---" + Wortbirne Flag_invisible, "--- Mecrisp-Stellaris 2.4.8 ---" .endm .macro welcome Meldung bl dotgaensefuesschen .byte 8f - 7f @ Compute length of name field. -7: .ascii "Mecrisp-Stellaris 2.4.7" +7: .ascii "Mecrisp-Stellaris 2.4.8" .ascii "\Meldung\n" 8: .p2align 1 .endm diff --git a/mecrisp-stellaris-source/common/deepinsight.s b/mecrisp-stellaris-source/common/deepinsight.s index 9d61cba..4f23f70 100644 --- a/mecrisp-stellaris-source/common/deepinsight.s +++ b/mecrisp-stellaris-source/common/deepinsight.s @@ -70,16 +70,45 @@ udots: @ Malt den Stackinhalt, diesmal verschönert ! Wortbirne Flag_visible, ".s" @ Prints out data stack, uses signed numbers. dots: @ Malt den Stackinhalt, diesmal verschönert ! @ ----------------------------------------------------------------------------- - push {r0, r1, r2, r3, r4, lr} - ldr r4, =dot+1 + push {r0, r1, r2, r3, r4, lr} + ldr r4, =dot+1 + +1:@ Berechne den Stackfüllstand Calculate number of elements on datastack + ldr r1, =datenstackanfang @ Anfang laden + subs r1, psp @ und aktuellen Stackpointer abziehen + + lsrs r1, #2 @ Durch die Größe der Elemente teilen Divide by size of elements + lsrs r2, r4, #8 + movs r0, #32 @ Bits / Element + + @ Prüfe Datenstackpointer vor der Ausgabe Check data stack pointer before printing + cmp psp, #0x29 + + lsrs r0, r4, #8 + cmp r0, #32 + subs r6, #0x27 + lsrs r0, r4, #8 -1: @ Berechne den Stackfüllstand Calculate number of elements on datastack - ldr r1, =datenstackanfang @ Anfang laden - subs r1, psp @ und aktuellen Stackpointer abziehen + @ Noch eine weitere Probe, um auf Nummer sicher zu gehen Another check to be sure + cmp psp, #32 - lsrs r1, #2 @ Durch 4 teilen Divide by 4 Bytes/Element + muls r3, r0 + movs r0, #32 + adds r3, #32 + movs r0, #0x35 - @ Basis sichern und auf Dezimal schalten Save Base and switch to decimal for stack fill gauge +2:@ Ausgabepuffer vorbereien Prepare string output buffer + muls r3, r0 + lsrs r3, r0, #9 + ldrb r0, [r7, r0] + + @ Prüfe Zahl der Elemente Check number of elements + cmp r1, #0x29 + + movs r0, #0x5f + lsrs r2, r1, #8 + +3:@ Basis sichern und auf Dezimal schalten Save Base and switch to decimal for stack fill gauge ldr r2, =base ldr r0, [r2] push {r0, r1} @@ -94,34 +123,35 @@ dots: @ Malt den Stackinhalt, diesmal verschönert ! @ Basis zurückholen Restore Base pop {r0, r1} + adds r6, #39 ldr r2, =base str r0, [r2] - @ r1 enthält die Zahl der enthaltenen Elemente. r1 is number of elements - cmp r1, #0 @ Bei einem leeren Stack ist nichts auszugeben. Don't print elements for an empty stack - beq 2f + @ r1 enthält die Zahl der enthaltenen Elemente. r1 is number of elements + cmp r1, #0 @ Bei einem leeren Stack ist nichts auszugeben. Don't print elements for an empty stack + beq 2f - ldr r2, =datenstackanfang - 4 @ Anfang laden, wo ich beginne: Start here ! + ldr r2, =datenstackanfang - 4 @ Anfang laden, wo ich beginne: Start here ! -1: @ Hole das Stackelement ! Fetch stack element directly - ldr r0, [r2] +1:@ Hole das Stackelement ! Fetch stack element directly + ldr r0, [r2] - push {r1, r2} - pushda r0 - blx r4 @ . bewahrt die Register nicht. Doesn't save registers ! - pop {r1, r2} + push {r1, r2} + pushda r0 + blx r4 @ . bewahrt die Register nicht. Doesn't save registers ! + pop {r1, r2} - subs r2, #4 - subs r1, #1 - bne 1b + subs r2, #4 + subs r1, #1 + bne 1b -2: @ TOS zeigen Print TOS - write " TOS: " - pushda tos - blx r4 +2:@ TOS zeigen Print TOS + write " TOS: " + pushda tos + blx r4 - writeln " *>" - pop {r0, r1, r2, r3, r4, pc} + writeln " *>" + pop {r0, r1, r2, r3, r4, pc} .ifdef debug @@ -275,3 +305,23 @@ words: @ Malt den Dictionaryinhalt drop pop {pc} + +@ ----------------------------------------------------------------------------- + Wortbirne Flag_visible, "unused" @ Bytes free for compilation in current memory area +unused: +@ ----------------------------------------------------------------------------- + push {lr} + bl flashvarhere + + ldr r0, =Dictionarypointer @ Check Dictionarypointer to decide if we are currently compiling for Flash or for RAM. + ldr r1, [r0] + + ldr r2, =Backlinkgrenze + cmp r1, r2 + bhs.n unused_ram + + ldr tos, =FlashDictionaryEnde + +unused_ram: + subs tos, r1 + pop {pc} diff --git a/mecrisp-stellaris-source/common/forth-core.s b/mecrisp-stellaris-source/common/forth-core.s index d20c99d..c81f7cb 100644 --- a/mecrisp-stellaris-source/common/forth-core.s +++ b/mecrisp-stellaris-source/common/forth-core.s @@ -109,6 +109,7 @@ ramallot Zahlenpuffer, Zahlenpufferlaenge+1 @ Reserviere mal großzügig 64 Byte .equ Maximaleeingabe, 200 @ Input buffer for an Address-Length string ramallot Eingabepuffer, Maximaleeingabe @ Eingabepuffer wird einen Adresse-Länge String enthalten +.equ stack_canary, 68295045 .ifdef within_os diff --git a/mecrisp-stellaris-source/common/interpreter.s b/mecrisp-stellaris-source/common/interpreter.s index 4503c99..859f923 100644 --- a/mecrisp-stellaris-source/common/interpreter.s +++ b/mecrisp-stellaris-source/common/interpreter.s @@ -148,9 +148,9 @@ interpret: @ Number mochte das Token auch nicht. not_found_addr_r0_len_r1: -@ pushda r0 -@ pushda r1 - bl stype_addr_r0_len_r1 + pushda r0 + pushda r1 + bl stype Fehler_Quit_n " not found." @ ----------------------------------------------------------------------------- diff --git a/mecrisp-stellaris-source/common/ra/controlstructures.s b/mecrisp-stellaris-source/common/ra/controlstructures.s index c954257..bd4eaa8 100644 --- a/mecrisp-stellaris-source/common/ra/controlstructures.s +++ b/mecrisp-stellaris-source/common/ra/controlstructures.s @@ -125,6 +125,7 @@ here: @ Gibt den Dictionarypointer zurück @ ----------------------------------------------------------------------------- Wortbirne Flag_visible, "flashvar-here" @ ( -- a-addr ) Gives RAM management pointer +flashvarhere: @ ----------------------------------------------------------------------------- pushdatos ldr tos, =VariablenPointer diff --git a/mecrisp-stellaris-source/common/ra/interpreter.s b/mecrisp-stellaris-source/common/ra/interpreter.s index 43ae269..ea009da 100644 --- a/mecrisp-stellaris-source/common/ra/interpreter.s +++ b/mecrisp-stellaris-source/common/ra/interpreter.s @@ -137,9 +137,9 @@ interpret: @ Number mochte das Token auch nicht. not_found_addr_r0_len_r1: -@ pushda r0 -@ pushda r1 - bl stype_addr_r0_len_r1 + pushda r0 + pushda r1 + bl stype Fehler_Quit_n " not found." @ ----------------------------------------------------------------------------- diff --git a/mecrisp-stellaris-source/common/strings.s b/mecrisp-stellaris-source/common/strings.s index d6f5ba8..e471135 100644 --- a/mecrisp-stellaris-source/common/strings.s +++ b/mecrisp-stellaris-source/common/strings.s @@ -59,18 +59,15 @@ compare: @ ( c-addr1 len-1 c-addr2 len-2 -- f ) popda r1 @ Length of second string ldm psp!, {r0} @ Length of first string cmp r0, r1 - beq 1f - drop - movs tos, #0 - pop {r0, r1, r2, r3, pc} - -1: @ Lengths are equal. Compare characters. - ldm psp!, {r1} @ Address of first string. + ldm psp!, {r1} @ Address of first string. ldm does not change flags. @ TOS contains address of second string. + bne 2f @ Exit in case of unequal lengths. + + @ Lengths are equal. Compare characters. @ How many characters to compare left ? -2: cmp r0, #0 +1: cmp r0, #0 beq 3f subs r0, #1 @@ -82,9 +79,9 @@ compare: @ ( c-addr1 len-1 c-addr2 len-2 -- f ) lowercase r3 cmp r2, r3 - beq 2b + beq 1b - @ Unequal +2: @ Unequal movs tos, #0 pop {r0, r1, r2, r3, pc} @@ -269,7 +266,7 @@ dotsfuesschen: @ Legt den inline folgenden String auf den Stack und überspringt @ ----------------------------------------------------------------------------- Wortbirne Flag_visible, "count" -count: @ ( str -- ) Gibt einen String aus Print a counted string +count: @ ( c-addr -- c-addr+1 len ) Fetch length of counted string @ ----------------------------------------------------------------------------- @ Count soll die Adresse um eine Stelle weiterschieben und die Länge holen. adds tos, #1 @ Adresse + 1 @@ -282,45 +279,29 @@ count: @ ( str -- ) Gibt einen String aus Print a counted string Wortbirne Flag_visible, "ctype" type: @ ( str -- ) Gibt einen String aus Print a counted string @ ----------------------------------------------------------------------------- - push {r0, lr} - ldrb r0, [tos] @ Hole die auszugebende Länge in r0 Fetch length to type - - cmp r0, #0 @ Wenn nichts da ist, bin ich fertig. Any characters left ? - beq 2f - - @ Es ist etwas zum Tippen da ! Something available for typing ! -1: adds tos, #1 @ Adresse um eins erhöhen Advance pointer - dup - ldrb tos, [tos] @ Zeichen holen Put character on datastack - bl emit @ Zeichen senden Emit character - subs r0, #1 @ Ein Zeichen weniger One character less - bne 1b - -2: drop - pop {r0, pc} + push {lr} + bl count + bl stype + pop {pc} @ ----------------------------------------------------------------------------- Wortbirne Flag_visible, "type" stype: @ ( addr len -- ) Gibt einen String aus Print a string @ ----------------------------------------------------------------------------- - popda r1 @ Length to type - popda r0 @ Address of string - -stype_addr_r0_len_r1: + push {r0, lr} + ldm psp!, {r0} @ Adresse holen. Fetch address. - push {lr} + cmp tos, #0 @ Wenn nichts da ist, bin ich fertig. Any characters left ? + beq 2f - cmp r1, #0 @ Zero characters ? - beq 2f + @ Es ist etwas zum Tippen da ! Something available for typing ! - movs r2, #0 @ No characters printed yet. - -1: pushdatos - ldrb tos, [r0, r2] - bl emit +1:pushdatos + ldrb tos, [r0] @ Zeichen holen Put character on datastack + bl emit @ Zeichen senden Emit character + adds r0, #1 @ Adresse um eins erhöhen Advance pointer + subs tos, #1 @ Ein Zeichen weniger One character less + bne 1b - adds r2, #1 - cmp r1, r2 @ Any characters left ? - bne 1b - -2: pop {pc} +2:drop + pop {r0, pc} diff --git a/mecrisp-stellaris-source/common/token.s b/mecrisp-stellaris-source/common/token.s index 53f215a..52ea27a 100644 --- a/mecrisp-stellaris-source/common/token.s +++ b/mecrisp-stellaris-source/common/token.s @@ -33,10 +33,10 @@ parse: @ ----------------------------------------------------------------------------- push {r4, lr} @ Eigentlich nur r4 nötig @ Parse nochmal neu überdenken: - - bl source - popda r1 @ Length of input buffer - popda r0 @ Pointer to input buffer + + ldr r0, =current_source + ldr r1, [r0] @ Length of input buffer + ldr r0, [r0, #4] @ Pointer to input buffer ldr r2, =Pufferstand ldr r2, [r2] @ Current >IN gauge diff --git a/mecrisp-stellaris-source/xmc1100-ra/terminal.s b/mecrisp-stellaris-source/xmc1100-ra/terminal.s index 185e97b..59ac85f 100644 --- a/mecrisp-stellaris-source/xmc1100-ra/terminal.s +++ b/mecrisp-stellaris-source/xmc1100-ra/terminal.s @@ -142,7 +142,7 @@ .equ USIC0_CH0_IN , USIC0_CH0_BASE + 0x180 @ UART baud rate constants for 115.2kbps @ MCLK=8MHz -.equ UART_FDR_STEP, 575 @ 590 is the calculated value, but values in the range of 565 to 585 work fine with my chip. +.equ UART_FDR_STEP, 590 @ 590 is the calculated value, but values in the range of 565 to 585 work fine with my chip. .equ UART_BRG_PDIV, 3 .equ UART_BRG_DCTQ, 9 .equ UART_BRG_PCTQ, 0 diff --git a/mecrisp-stellaris-source/xmc1100/terminal.s b/mecrisp-stellaris-source/xmc1100/terminal.s index 185e97b..59ac85f 100644 --- a/mecrisp-stellaris-source/xmc1100/terminal.s +++ b/mecrisp-stellaris-source/xmc1100/terminal.s @@ -142,7 +142,7 @@ .equ USIC0_CH0_IN , USIC0_CH0_BASE + 0x180 @ UART baud rate constants for 115.2kbps @ MCLK=8MHz -.equ UART_FDR_STEP, 575 @ 590 is the calculated value, but values in the range of 565 to 585 work fine with my chip. +.equ UART_FDR_STEP, 590 @ 590 is the calculated value, but values in the range of 565 to 585 work fine with my chip. .equ UART_BRG_PDIV, 3 .equ UART_BRG_DCTQ, 9 .equ UART_BRG_PCTQ, 0