From 67d25d837ac55f28a366c0a3b262e439a6e75fc3 Mon Sep 17 00:00:00 2001 From: Dimitri Sokolyuk Date: Sat, 19 Aug 2017 12:15:28 +0200 Subject: Add AmForth --- .../lib/forth2012/tester/searchordertest.fth | 178 +++++++++++++++++++++ 1 file changed, 178 insertions(+) create mode 100644 amforth-6.5/common/lib/forth2012/tester/searchordertest.fth (limited to 'amforth-6.5/common/lib/forth2012/tester/searchordertest.fth') diff --git a/amforth-6.5/common/lib/forth2012/tester/searchordertest.fth b/amforth-6.5/common/lib/forth2012/tester/searchordertest.fth new file mode 100644 index 0000000..79f9de9 --- /dev/null +++ b/amforth-6.5/common/lib/forth2012/tester/searchordertest.fth @@ -0,0 +1,178 @@ +\ To test the ANS Forth search-order word set and search order extensions + +\ 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.5 1 April 2012 Tests placed in the public domain. +\ 0.4 6 March 2009 { and } replaced with T{ and }T +\ 0.3 20 April 2007 ANS Forth words changed to upper case +\ 0.2 30 Oct 2006 updated following GForth tests to get +\ initial search order into a known state +\ 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: +\ FORTH-WORDLIST GET-ORDER SET-ORDER ALSO ONLY FORTH GET-CURRENT +\ SET-CURRENT DEFINITIONS PREVIOUS SEARCH-WORDLIST WORDLIST FIND +\ Words not fully tested: +\ ORDER only tests that it executes, display is implementation +\ dependent and should be visually inspected + +\ ------------------------------------------------------------------------------ +\ Assumptions and dependencies: +\ - tester.fr or ttester.fs has been loaded prior to this file +\ - that ONLY FORTH DEFINITIONS will work at the start of the file +\ to ensure the search order is in a known state +\ ------------------------------------------------------------------------------ + +ONLY FORTH DEFINITIONS + +TESTING Search-order word set + +DECIMAL + +VARIABLE wid1 VARIABLE wid2 + +: save-orderlist ( widn ... wid1 n -> ) DUP , 0 ?DO , LOOP ; + +\ ------------------------------------------------------------------------------ +TESTING FORTH-WORDLIST GET-ORDER SET-ORDER + +T{ FORTH-WORDLIST wid1 ! -> }T + +CREATE order-list + +T{ GET-ORDER save-orderlist -> }T + +: get-orderlist ( -- widn ... wid1 n ) + order-list DUP @ CELLS ( -- ad n ) + OVER + ( -- ad ad' ) + ?DO I @ -1 CELLS +LOOP ( -- ) +; + +T{ GET-ORDER OVER -> GET-ORDER wid1 @ }T \ Forth wordlist at top +T{ GET-ORDER SET-ORDER -> }T \ Effectively noop +T{ GET-ORDER -> get-orderlist }T \ Check nothing changed +T{ get-orderlist DROP get-orderlist 2* SET-ORDER -> }T +T{ GET-ORDER -> get-orderlist DROP get-orderlist 2* }T +T{ get-orderlist SET-ORDER GET-ORDER -> get-orderlist }T + +\ ------------------------------------------------------------------------------ +TESTING ALSO ONLY FORTH + +T{ ALSO GET-ORDER -> get-orderlist OVER SWAP 1+ }T +T{ ONLY FORTH GET-ORDER -> get-orderlist }T \ See assumptions above + +\ ------------------------------------------------------------------------------ +TESTING GET-CURRENT SET-CURRENT WORDLIST (simple) + +T{ GET-CURRENT -> wid1 @ }T \ See assumptions above +T{ WORDLIST wid2 ! -> }T +T{ wid2 @ SET-CURRENT -> }T +T{ GET-CURRENT -> wid2 @ }T +T{ wid1 @ SET-CURRENT -> }T + +\ ------------------------------------------------------------------------------ +TESTING minimum search order list contains FORTH-WORDLIST and SET-ORDER + +: so1 SET-ORDER ; \ In case it is unavailable in the forth wordlist + +T{ ONLY FORTH-WORDLIST 1 SET-ORDER get-orderlist so1 -> }T +T{ GET-ORDER -> get-orderlist }T + +\ ------------------------------------------------------------------------------ +TESTING GET-ORDER SET-ORDER with 0 and -1 number of wids argument + +: so2a GET-ORDER get-orderlist SET-ORDER ; \ To recover search order +: so2 0 SET-ORDER so2a ; + +T{ so2 -> 0 }T \ 0 set-order leaves an empty search order + +: so3 -1 SET-ORDER so2a ; +: so4 ONLY so2a ; + +T{ so3 -> so4 }T \ -1 SET-ORDER = ONLY + +\ ------------------------------------------------------------------------------ +TESTING DEFINITIONS PREVIOUS + +T{ ONLY FORTH DEFINITIONS -> }T +T{ GET-CURRENT -> FORTH-WORDLIST }T +T{ GET-ORDER wid2 @ SWAP 1+ SET-ORDER DEFINITIONS GET-CURRENT -> wid2 @ }T +T{ GET-ORDER -> get-orderlist wid2 @ SWAP 1+ }T +T{ PREVIOUS GET-ORDER -> get-orderlist }T +T{ DEFINITIONS GET-CURRENT -> FORTH-WORDLIST }T + +\ ------------------------------------------------------------------------------ +TESTING SEARCH-WORDLIST WORDLIST FIND + +ONLY FORTH DEFINITIONS +VARIABLE xt ' DUP xt ! +VARIABLE xti ' .( xti ! \ Immediate word + +T{ S" DUP" wid1 @ SEARCH-WORDLIST -> xt @ -1 }T +T{ S" .(" wid1 @ SEARCH-WORDLIST -> xti @ 1 }T +T{ S" DUP" wid2 @ SEARCH-WORDLIST -> 0 }T + +: c"dup" C" DUP" ; +: c".(" C" .(" ; +: c"x" C" unknown word" ; + +T{ c"dup" FIND -> xt @ -1 }T +T{ c".(" FIND -> xti @ 1 }T +T{ c"x" FIND -> c"x" 0 }T + +\ ------------------------------------------------------------------------------ +TESTING new definitions are put into the correct wordlist + +: alsowid2 ALSO GET-ORDER wid2 @ ROT DROP SWAP SET-ORDER ; +alsowid2 +: w1 1234 ; +DEFINITIONS +: w1 -9876 ; IMMEDIATE + +ONLY FORTH +T{ w1 -> 1234 }T +DEFINITIONS +T{ w1 -> 1234 }T +alsowid2 +T{ w1 -> -9876 }T +DEFINITIONS +T{ w1 -> -9876 }T + +ONLY FORTH DEFINITIONS + +: so5 DUP IF SWAP EXECUTE THEN ; + +T{ S" w1" wid1 @ SEARCH-WORDLIST so5 -> -1 1234 }T +T{ S" w1" wid2 @ SEARCH-WORDLIST so5 -> 1 -9876 }T + +: c"w1" C" w1" ; +T{ alsowid2 c"w1" FIND so5 -> 1 -9876 }T +T{ PREVIOUS c"w1" FIND so5 -> -1 1234 }T + +\ ------------------------------------------------------------------------------ +TESTING ORDER \ Should display search order and compilation wordlist + +CR .( ONLY FORTH DEFINITIONS search order and compilation list) CR +T{ ONLY FORTH DEFINITIONS ORDER -> }T + +CR .( Plus another unnamed wordlist at the head of the search order) CR +T{ alsowid2 DEFINITIONS ORDER -> }T + +\ ------------------------------------------------------------------------------ + +CR .( End of Search Order word tests) CR + +ONLY FORTH DEFINITIONS \ Leave search order in the standard state -- cgit v1.2.3