The ultimate Forth Benchmark

: BENCHME ( xt n -- )
  DUP >R 0 DO
    DUP EXECUTE
    [CHAR] . EMIT
  LOOP
  DROP R> SPACE . ." Iterations." SPACE ;

DECIMAL
: DDBENCH 1 32767 0 DO DUP DROP LOOP DROP ;
FIND DDBENCH 100 BENCHME

DECIMAL
32000 CONSTANT INTMAX

VARIABLE INTRESULT

: DOINT 
  1 DUP INTRESULT DUP >R !
  BEGIN 
    DUP INTMAX <
  WHILE 
    DUP NEGATE R@ +! 1+
    DUP R@ +! 1+
    R@ @ OVER * R@ ! 1+
    R@ @ OVER / R@ ! 1+
  REPEAT
  R> DROP DROP ;

FIND DOINT 100 BENCHME

DECIMAL
: FIB2
  0 1 ROT 0 DO
    OVER + SWAP
  LOOP DROP ;

: FIB2-BENCH 1000 0 DO
    I FIB2 DROP
  LOOP ;

FIND FIB2-BENCH 10 BENCHME

DECIMAL
: FIB2
  0 1 ROT 0 DO
    OVER + SWAP
  LOOP DROP ;

: FIB2-BENCH 1000 0 DO
    I FIB2 DROP
  LOOP ;

FIND FIB2-BENCH 10 BENCHME

DECIMAL
: BOTTOM ;
: 1ST BOTTOM BOTTOM ;  : 2ND 1ST 1ST ;      : 3RD 2ND 2ND ;
: 4TH 3RD 3RD ;        : 5TH 4TH 4TH ;      : 6TH 5TH 5TH ;
: 7TH 6TH 6TH ;        : 8TH 7TH 7TH ;      : 9TH 8TH 8TH ;
: 10TH 9TH 9TH ;       : 11TH 10TH 10TH ;   : 12TH 11TH 11TH ;
: 13TH 12TH 12TH ;     : 14TH 13TH 13TH ;   : 15TH 14TH 14TH ;
: 16TH 15TH 15TH ;     : 17TH 16TH 16TH ;   : 18TH 17TH 17TH ;
: 19TH 18TH 18TH ;     : 20TH 19TH 19TH ;   : 21TH 20TH 20TH ;
: 22TH 21TH 21TH ;     : 23TH 22TH 22TH ;   : 24TH 23TH 23TH ;
: 25TH 24TH 24TH ;
: 32MILLION   25TH ;
:  1MILLION   20TH ;
DECIMAL
FIND 1MILLION 10 BENCHME
FIND 32MILLION 10 BENCHME

DECIMAL

: MYBOUNDS OVER + SWAP ;
: ALIGN ;              ( No such constraint on 16 bit targets )

1 CELLS CONSTANT CELL

VARIABLE SEED

: INITIATE-SEED ( -- )  4931 SEED ! ;
: RANDOM ( -- N )  SEED @ 613 * 5179 + 32767 AND DUP SEED ! ;

1500 CONSTANT ELEMENTS

ALIGN CREATE LIST ELEMENTS CELLS ALLOT

: INITIATE-LIST ( -- )
  LIST ELEMENTS CELLS + LIST DO
    RANDOM I ! CELL
  +LOOP ;

: VERIFY-LIST ( -- )
  LIST ELEMENTS 1- CELLS MYBOUNDS DO
    I 2@ < IF
      ." BUBBLE-SORT: not sorted" ABORT
    THEN
  CELL +LOOP ;

: BUBBLE-WITH-FLAG ( -- )
  ." Bubbling..." CR
  1 ELEMENTS 1 DO
    [CHAR] . EMIT
    -1 LIST ELEMENTS I - CELLS MYBOUNDS DO
      I 2@ < IF
        I 2@ SWAP I 2! DROP 0
      THEN
    CELL +LOOP 
    IF LEAVE THEN
  LOOP SPACE DROP ;
  
: BUBBLE-SORT-WITH-FLAG ( -- )
  INITIATE-SEED
  INITIATE-LIST
  BUBBLE-WITH-FLAG
  VERIFY-LIST ;

: DUMP-LIST ( -- )
  CR LIST ELEMENTS CELLS + LIST DO
    I @ 7 U.R SPACE CELL
  +LOOP CR ;

DECIMAL
1 CELLS CONSTANT CELL
: CELL+ CELL + ;
: CELL- CELL - ;

VARIABLE SEED
: INITIATE-SEED ( -- )  4931 SEED ! ;
: RANDOM ( -- N )  SEED @ 613 * 5179 + 32767 AND DUP SEED ! ;
1500 CONSTANT ELEMENTS
CREATE LIST ELEMENTS CELLS ALLOT

: INITIATE-LIST ( -- )
  LIST ELEMENTS CELLS + LIST DO
    RANDOM I ! CELL
  +LOOP ;

: DUMP-LIST ( -- )
  CR LIST ELEMENTS CELLS + LIST DO
    I @ 7 U.R SPACE CELL
  +LOOP CR ;

: MID ( l r -- mid ) OVER - 2/ CELL NEGATE AND + ;
: EXCH ( addr1 addr2 -- ) OVER @ OVER @
  SWAP ROT ! SWAP ! ;
: PARTITION ( l r -- l r r2 l2 )
  2DUP MID @ >R ( r: pivot )
  2DUP BEGIN
    SWAP BEGIN DUP @ R@ < WHILE CELL+ REPEAT
    SWAP BEGIN R@ OVER @ < WHILE CELL- REPEAT
    2DUP <= IF 2DUP EXCH >R CELL+ R> CELL- THEN
    2DUP >
  UNTIL R> DROP ;
 
: QSORT ( l r -- )
  PARTITION SWAP ROT
  2DUP < IF RECURSE ELSE 2DROP THEN
  2DUP < IF RECURSE ELSE 2DROP THEN ;
 
: QUICK-SORT ( -- )
  LIST ELEMENTS DUP 2 < IF
    2DROP EXIT
  THEN
  1- CELLS OVER + QSORT ;

: QUICK-SORT-BENCHMARK ( -- )
  INITIATE-SEED
  INITIATE-LIST
  QUICK-SORT
  ( DUMP-LIST ) ;

FIND QUICK-SORT-BENCHMARK 50 BENCHME

HEX
( Adapted from "Hacker's Delight" Second Edition    )
( by Henry S. Warren Jr., Edt by Addison-Wesley     )
( Chapter 5 "Counting bits", page 82                )

: COUNTBITS ( uu -- #bits )
  DUP -1 SHIFT 5555 AND -
  DUP 3333 AND SWAP -2 SHIFT 3333 AND +
  DUP -4 SHIFT + 0F0F AND
  DUP -8 SHIFT +
  1F AND ;

DECIMAL
: BITSINCELL ( -- )
  8192 0 DO
    I COUNTBITS DROP
  LOOP ;

FIND BITSINCELL 100 BENCHME

\ -------------------------------------------------------------
\ [BENCHMARK] Glibreath's fixed algorithm:
\ Eratosthenes' sieve from ORNL/TM10656 (Martin Marietta).

DECIMAL
8190 CONSTANT SIZE
VARIABLE FLAGS SIZE 1+ ALLOT

: DO-PRIME
  FLAGS SIZE 1+ 1 FILL
  0 SIZE 0 DO
    FLAGS I + C@ IF
      I DUP + 3 + DUP I +
      BEGIN
        DUP SIZE <=
      WHILE
        0 OVER FLAGS + C! OVER +
      REPEAT
      DROP DROP 1+
    THEN
  LOOP DROP ;

FIND DO-PRIME 50 BENCHME

DECIMAL
8192 CONSTANT BUFSIZE
VARIABLE BUF1 HERE BUFSIZE 1+ ALLOT BUF1 !
VARIABLE BUF2 HERE BUFSIZE 1+ ALLOT BUF2 !
: TEST-CMOVE 50 0 DO BUF1 @ BUF2 @ BUFSIZE CMOVE LOOP ;
: TEST-CMOVE> 50 0 DO BUF2 @ BUF1 @ BUFSIZE CMOVE> LOOP ;
: TEST-MOVE> 50 0 DO
    BUF1 @ BUF2 @ BUFSIZE 1 CELLS / MOVE
  LOOP ;
: TEST-<MOVE 50 0 DO
    BUF2 @ BUF1 @ BUFSIZE 1 CELLS / MOVE
  LOOP ;
: MOVE-BENCH TEST-CMOVE TEST-CMOVE> TEST-MOVE> TEST-<MOVE ;

FIND MOVE-BENCH 250 BENCHME

DECIMAL
: GCD1 OVER IF
    BEGIN
      DUP
    WHILE
      2DUP U> IF SWAP THEN OVER -
    REPEAT
    DROP
  ELSE
    DUP IF
      DROP
    ELSE
      2DROP 1
    THEN
  THEN ;

: GCD1-BENCH 100 0 DO
    100 0 DO
      J I GCD1 DROP
    LOOP
  LOOP ;

FIND GCD1-BENCH 10 BENCHME

DECIMAL
: GCD2 ( a b -- gcd )
  2DUP     D0= IF 2DROP 1 EXIT THEN
  DUP      0=  IF  DROP   EXIT THEN
  SWAP DUP 0=  IF  DROP   EXIT THEN
  BEGIN
    2DUP -
  WHILE
    2DUP < IF
      OVER -
    ELSE
      SWAP OVER - SWAP
    THEN
  REPEAT NIP ;

: GCD2-BENCH 100 0 DO
    100 0 DO
      J I GCD2 DROP
    LOOP
  LOOP ;

FIND GCD2-BENCH 10 BENCHME

\ -------------------------------------------------------------
\ GCD3 algorithm (provided by Paul E. Bennett).

DECIMAL
: GCD3 ( S: x y -- n) ( MCC=5 )
\ *G Find the Greatest Common Divisor "gcd" of two
\ ** integers "x and y", when at least one of them is
\ ** not zero. Return the largest positive integer "n"
\ ** that divides the two numbers without a remainder.
\ ** For example, the GCD of 8 and 12 is 4.
  2DUP <= IF
    SWAP
  THEN
  BEGIN
    TUCK MOD
    DUP 0=
  UNTIL DROP ;

: GCD3-BENCH 100 1 DO
    100 1 DO
      J I GCD3 DROP
    LOOP
  LOOP ;

FIND GCD3-BENCH 10 BENCHME

HEX 
5 CONSTANT FIVE 
VARIABLE BVAR 

: BENCH 
  100 0 DO 
    1 BEGIN 
        DUP SWAP 
        DUP ROT DROP 
        1 AND IF 
          FIVE + 
        ELSE 
          1- 
        THEN 
        BVAR ! BVAR @ 
        DUP 0100 AND 
     UNTIL DROP 
   LOOP ;

DECIMAL
FIND BENCH 50 BENCHME

( Collatz-Schritt. Null wenn Ueberlauf )
: cn+1 		( cn -- cm )
  2 /mod swap			
  if dup 10922 < 	( kein ueberlauf ? )
    if 3 * 2+ 
    else drop 0 then
  then
;
( Collatz-Folge drucken                         )
( dieses Wort wird im Benchmark nicht benoetigt )
( es druckt die Collatz-Folge aus               )
: coll. 	( cn -- )
  cr
  begin dup 1 > while
    cn+1 dup 8 u.r
  repeat
  drop		( always 1 )
;
( Collatz-Folge zaehlen. Null wenn Ueberlauf )
: ccnt 		( cn -- cnt)
  0 swap 	( cnt cn )
  begin dup 1 > while
  cn+1 dup 
	if swap 1+ swap ( zaehlen )
	else drop 0
	then
  repeat
  drop
;
( Maximum fuer alle Folgen bis k bestimmen )
: cmax 		( k -- max )
  0 swap	( max k )
  begin dup 0 > while
    dup ccnt 	( max k cnt )
    rot  	( k cnt max )
    max		( k max )
    swap	( max k )
    1-		( max k-1 )
  repeat
  drop
;
( Funktionstest, Ergebniss muss die Zahl "126" sein )
32101 cmax .

\ -------------------------------------------------------------
\ Takeuchi algorithm
\ Adapted from FORTH-83 (PICK). NIP is ANSI (and builtin).

DECIMAL
: 3DUP 3 PICK 3 PICK 3 PICK ;
: TAK ( x y z -- t )
  OVER 4 PICK < NEGATE IF
    NIP NIP EXIT
  THEN
  3DUP ROT  1- -ROT RECURSE >R
  3DUP SWAP 1- -ROT SWAP RECURSE >R
            1- -ROT RECURSE
  R> SWAP R>   -ROT RECURSE ;

: TAKBENCH ( -- )
  0 1000 0 DO
    DROP 18 12 6 TAK
  LOOP
  DROP ;

FIND TAKBENCH 200 BENCHME

( A simple 6502 emulation benchmark                       cas )
( only 11 opcodes are implemented. The memory layout is:      )                   
(  2kB RAM at 0000-07FF, mirrored throughout 0800-7FFF        )
( 16kB ROM at 8000-BFFF, mirrored at C000                     )

DECIMAL
CREATE RAM 2048 ALLOT
: >RAM [ HEX ] 7FF  [ DECIMAL ] AND RAM + ;

CREATE ROM 16384 ALLOT
: >ROM [ HEX ] 3FFF [ DECIMAL ] AND ROM + ;

( 6502 registers                                              )
VARIABLE REG-A   VARIABLE REG-X   VARIABLE REG-Y
VARIABLE REG-S   VARIABLE REG-PC  : REG-PC+ REG-PC +! ;

( 6502 flags                                                  )
VARIABLE FLAG-C  VARIABLE FLAG-N  VARIABLE CYCLE
VARIABLE FLAG-Z  VARIABLE FLAG-V  : CYCLE+ CYCLE +! ;

HEX
: W@ DUP C@ SWAP 1+ C@ 100 * OR ;
: CS@ C@ DUP 80 AND IF 100 - THEN ;

: READ-BYTE ( address -- )
  DUP 8000 < IF >RAM C@ ELSE >ROM C@ THEN ;
: READ-WORD ( address -- )
  DUP 8000 < IF >RAM W@ ELSE >ROM W@ THEN ;
: DOJMP ( JMP aaaa )
  REG-PC @ >ROM W@ REG-PC ! 3 CYCLE+ ;
: DOLDA ( LDA aa )
  REG-PC @ >ROM C@ RAM + C@ DUP DUP REG-A !
  FLAG-Z ! 80 AND FLAG-N ! 1 REG-PC+ 3 CYCLE+ ;
: DOSTA ( STA aa )
  REG-A @ REG-PC @ >ROM C@ RAM + C! 1 REG-PC+ 3 CYCLE+ ;
: DOBEQ ( BEQ <aa )
  FLAG-Z @ 0= IF REG-PC @ >ROM CS@ 1+ REG-PC+ ELSE 1 REG-PC+
  THEN 3 CYCLE+ ;
: DOLDAI ( LDA #aa )
  REG-PC @ >ROM C@ DUP DUP REG-A ! FLAG-Z ! 80 AND FLAG-N !
  1 REG-PC+ 2 CYCLE+ ;
: DODEX ( DEX )
  REG-X @ 1- FF AND DUP DUP REG-X ! FLAG-Z ! 80 AND FLAG-N !
  2 CYCLE+ ;
: DODEY ( DEY )
  REG-Y @ 1- FF AND DUP DUP REG-Y ! FLAG-Z ! 80 AND FLAG-N !
  2 CYCLE+ ;
: DOINC ( INC aa )
  REG-PC @ >ROM C@ RAM + DUP C@ 1+ FF AND DUP ROT ROT SWAP C!
  DUP FLAG-Z ! 80 AND FLAG-N !  1 REG-PC+ 3 CYCLE+ ;
: DOLDY ( LDY aa )
  REG-PC @ >ROM C@ DUP DUP REG-Y ! FLAG-Z ! 80 AND FLAG-N !
  1 REG-PC+ 2 CYCLE+ ;
: DOLDX ( LDX #aa )
  REG-PC @ >ROM C@ DUP DUP REG-X ! FLAG-Z ! 80 AND FLAG-N !
  1 REG-PC+ 2 CYCLE+ ;
: DOBNE ( BNE <aa )
  FLAG-Z @ IF REG-PC @ >ROM CS@ 1+ REG-PC+ ELSE 1 REG-PC+ THEN
  3 CYCLE+ ;
: 6502EMU ( cycles -- )
  BEGIN CYCLE @ OVER  < WHILE
    REG-PC @ >ROM C@ 1 REG-PC+
    DUP 4C = IF DOJMP THEN      DUP A5 = IF DOLDA THEN
    DUP 85 = IF DOSTA THEN      DUP F0 = IF DOBEQ THEN
    DUP D0 = IF DOBNE THEN      DUP A9 = IF DOLDAI THEN
    DUP CA = IF DODEX THEN      DUP 88 = IF DODEY THEN
    DUP E6 = IF DOINC THEN      DUP A0 = IF DOLDY THEN
        A2 = IF DOLDX THEN
  REPEAT DROP ;

CREATE TESTCODE
  A9 C, 00 C,  ( start: LDA #0                                )
  85 C, 08 C,  (        STA 08                                )
  A2 C, 0A C,  (        LDX #10                               )
  A0 C, 0A C,  ( loop1: LDY #10                               )
  E6 C, 08 C,  ( loop2: INC 08                                )
  88 C,        (        DEY                                   )
  D0 C, FB C,  (        BNE loop2                             )
  CA C,        (        DEX                                   )
  D0 C, F6 C,  (        BNE loop1                             )
  4C C, 00 C, 80 C, (   JMP start                             )

: INIT-VM 13 0 DO                 ( Initialize the ROM        )
    I TESTCODE + C@ I ROM + C!
  LOOP
  0 CYCLE ! 8000 REG-PC ! ;

: BENCH6502 100 0 [ DECIMAL ] DO
    INIT-VM 6502 6502EMU [CHAR] . EMIT
  LOOP SPACE ;

: benchme ( xt n -- ) \ executes the word with the execution token "xt" n-times
  dup >r              \ save number of iterations
  0 do dup execute loop \ execute word. word must have a neutral stack effect
  cr r> . ." Iterations." cr \ emit message
;

DECIMAL

: DDBENCH 1 32767 0 DO DUP DROP LOOP DROP ;

' DDBENCH 100 BENCHME

32000 constant intMax

variable intResult

: DoInt
  1 dup intResult dup >r !
  begin
    dup intMax <
  while
    dup negate r@ +! 1+
    dup r@ +! 1+
    r@ @ over * r@ ! 1+
    r@ @ over / r@ ! 1+
  repeat
  r> drop drop
;

https://en.wikipedia.org/wiki/Fibonacci_number

Note: On an 8 or 16 bit machine, the Fibonacci numbers will roll over quickly and the programs will not produce a valid Fibonacci sequence anymore. But still the machines will do some number crunching work that will eat CPU time. We measure the time. The numbers are thrown away anyway.

This version uses a recursive call. Recursive calls are not standardized in early Forth systems. The word to call the current definition can have different names in your forth (recurse, self, …). Please check you system documentation (if available) or the wordlist (using WORDS or VLIST).

: fib1 ( n1 -- n2 )
    dup 2 < if drop 1 exit then
    dup  1- recursive 
    swap 2- recursive  + ;
    
: fib1-bench 1000 0 do 
    20 0 do i fib1 drop loop
  loop ;

' fib1-bench 10 benchme

: fib2 ( n1 -- n2 )                                                                
   0 1 rot 0 do 
      over + swap loop 
   drop ;
 
: fib2-bench 1000 0 do
    20 0 do i fib2 drop loop
  loop ;

' fib2-bench 10 benchme

\ Forth nesting (NEXT) Benchmark                     cas20101204                   
: bottom ;                                                                         
: 1st bottom bottom ;  : 2nd 1st 1st ;      : 3rd 2nd 2nd ;                        
: 4th 3rd 3rd ;        : 5th 4th 4th ;      : 6th 5th 5th ;                        
: 7th 6th 6th ;        : 8th 7th 7th ;      : 9th 8th 8th ;                        
: 10th 9th 9th ;       : 11th 10th 10th ;   : 12th 11th 11th ;                     
: 13th 12th 12th ;     : 14th 13th 13th ;   : 15th 14th 14th ;                     
: 16th 15th 15th ;     : 17th 16th 16th ;   : 18th 17th 17th ;                     
: 19th 18th 18th ;     : 20th 19th 19th ;   : 21th 20th 20th ;                     
: 22th 21th 21th ;     : 23th 22th 22th ;   : 24th 23th 23th ;                     
: 25th 24th 24th ;                                                                 

: 32million   CR ." 32 million nest/unnest operations" 25th ;                      
:  1million   CR ."  1 million nest/unnest operations" 20th ;                      

CR .( enter 1million or 32million )

Note: The Forth Word MOVE always moves a cell. On Forth 79, Fig-Forth and Forth 83 Systems this is always 16 bit, not matter the CPU architecture. On more modern Forth, the call size is usually the CPU architecture bit size (32bit, 64bit or even 128bit). These machines need to move more data in this test. If you want, you can take this into account by dividing the count loop for the later two tests that use MOVE by the multiples of your cell size (2 for 32bit machines, 4 for 64bit etc).

\ Forth Memory Move Benchmark                       cas 20101204                   
 8192 CONSTANT bufsize                                                             
 VARIABLE buf1 HERE bufsize 1+ allot BUF1 !                                         
 VARIABLE buf2 HERE bufsize 1+ allot BUF2 !                                         
                                                                                    
 : test-CMOVE 49 0 DO BUF1 @ BUF2 @ bufsize CMOVE LOOP ;                            
                                                                                    
 : test-CMOVE> 49 0 DO BUF2 @ BUF1 @ bufsize CMOVE> LOOP ;                          
                                                                                    
 : test-MOVE> 49 0 DO BUF1 @ BUF2 @ bufsize MOVE LOOP ;                             
                                                                                    
 : test-<MOVE 49 0 DO BUF2 @ BUF1 @ bufsize MOVE LOOP ;     
 
 : move-bench test-CMOVE test-CMOVE> test-MOVE> test-<MOVE ;

\ Forth Benchmark - count bits in byte              cas 20101204

VARIABLE cnt

HEX 
: countbits ( uu -- #bits )
  cnt off
  8 0 DO dup 01010101  and cnt +!
         2/
  LOOP drop
  0 cnt 4 bounds DO i C@ + LOOP ;

DECIMAL

: bench5
  8192 0 DO I countbits drop LOOP ;

"BOUNDS" can be defined with:

( Convert str len to range for DO-loop )
: bounds ( str len -- str+len str )
  over + swap ;

"OFF" can be defined with:

( stores zero into address )
: OFF ( addr -- )
  0 SWAP ! ;

FIG-Forth derived systems or Forth-79 Systems require the initial value of a variable on the stack.

So instead of "VARIABLE FLAGS 0 FLAGS !" use "0 VARIABLE FLAGS".

\ Sieve Benchmark -- the classic Forth benchmark    cas 20101204                   
                                                                                    
 8192 CONSTANT SIZE   
 VARIABLE FLAGS  
 0 FLAGS !  
 SIZE ALLOT                         
                                                                                    
 : DO-PRIME                                                                         
   FLAGS SIZE 1 FILL  ( set array )                                                 
   0 ( 0 COUNT ) SIZE 0                                                             
   DO FLAGS I + C@                                                                  
     IF I DUP + 3 + DUP I +                                                         
        BEGIN DUP SIZE <                                                            
        WHILE 0   OVER FLAGS +  C!  OVER +  REPEAT                                  
        DROP DROP 1+                                                                
     THEN                                                                           
 LOOP                                                                               
 . ." Primes" CR ;

\ gcd - greatest common divisor                     cas 20101204                   
                                                                                    
 : gcd ( a b -- gcd )                                                               
   OVER IF                                                                          
     BEGIN                                                                          
       DUP WHILE                                                                    
          2DUP U> IF SWAP THEN OVER -                                               
     REPEAT DROP ELSE                                                               
     DUP IF NIP ELSE 2DROP 1 THEN                                                   
   THEN ;  
   
: gcd1-bench 100 0 DO 
      100 0 DO j i gcd drop loop
      loop ;

another gcd with O(2) runtime speed

 : gcd2 ( a b -- gcd )                                                              
   2DUP        D0= IF  2DROP 1 EXIT   THEN                                          
   DUP          0= IF   DROP   EXIT   THEN                                          
   SWAP DUP     0= IF   DROP   EXIT   THEN                                          
   BEGIN  2DUP -                                                                    
   WHILE  2DUP < IF OVER -                                                          
                 ELSE SWAP OVER - SWAP                                              
                 THEN                                                               
   REPEAT NIP ;          

: gcd2-bench 100 0 DO 
      100 0 DO j i gcd2 drop loop
      loop ;

"D0=" compares a double integer against zero. It can be defined as:

: D0= ( d d -- f )
  + 0= ;

( takeuchi benchmark in volksForth Forth-83 ) ( see http://en.wikipedia.org/wiki/Tak_(function) )

DECIMAL

 : 3dup 2 pick 2 pick 2 pick ;                                                        

 : tak ( x y z -- t )                                                                 
   over 3 pick < NEGATE IF nip nip exit then                                          
   3dup rot 1- -rot recursive >r                                                      
   3dup swap 1- -rot swap recursive >r                                                
             1- -rot recursive                                                        
   r> swap r> -rot recursive ;                                                        
                                                                                      
 : takbench ( -- )                                                                    
   0 1000 0 DO DROP 18 12 6 tak LOOP ;

\ A simple 6502 emulattion benchmark                         cas                     
\ only 11 opcodes are implemented. The memory layout is:                             
\  2kB RAM at 0000-07FF, mirrored throughout 0800-7FFF                               
\ 16kB ROM at 8000-BFFF, mirrored at C000                                            
decimal                                                                              
create ram 2048 allot   : >ram $7FF  and ram + ;                                     
create rom 16384 allot  : >rom $3FFF and rom + ;                                     
\ 6502 registers                                                                     
variable reg-a   variable reg-x  variable reg-y                                      
variable reg-s   variable reg-pc  : reg-pc+ reg-pc +! ;                              
\ 6502 flags                                                                         
variable flag-c  variable flag-n   variable cycle                                    
variable flag-z  variable flag-v  : cycle+ cycle +! ;                                
hex                                                                                  
: w@ dup c@ swap 1+ c@ 100 * or ;                                                    
: cs@ c@ dup 80 and if 100 - then ;        

: read-byte ( address -- )                                                           
  dup 8000 < if >ram c@ else >rom c@ then ;                                          
: read-word ( address -- )                                                           
  dup 8000 < if >ram w@ else >rom w@ then ;                                          
: dojmp ( JMP aaaa )                                                                 
  reg-pc @ >rom w@ reg-pc ! 3 cycle+ ;                                               
: dolda ( LDA aa )                                                                   
  reg-pc @ >rom c@ ram + c@ dup dup reg-a !                                          
  flag-z ! 80 and flag-n ! 1 reg-pc+ 3 cycle+ ;                                      
: dosta ( STA aa )                                                                   
  reg-a @ reg-pc @ >rom c@ ram + c! 1 reg-pc+ 3 cycle+ ;                             
: dobeq ( BEQ <aa )                                                                  
  flag-z @ 0= if reg-pc @ >rom cs@ 1+ reg-pc+ else 1 reg-pc+ then 3 cycle+ ;   
: doldai ( LDA #aa )                                                                 
  reg-pc @ >rom c@ dup dup reg-a ! flag-z ! 80 and flag-n !                          
  1 reg-pc+ 2 cycle+ ;                                                               
: dodex ( DEX )                                                                      
  reg-x @ 1- FF and dup dup reg-x ! flag-z ! 80 and flag-n !                         
  2 cycle+ ;                                                                         
: dodey ( DEY )                                                                      
  reg-y @ 1- ff and dup dup reg-y ! flag-z ! 80 and flag-n !                         
  2 cycle+ ;                                                                         
: doinc ( INC aa )                                                                   
  reg-pc @ >rom c@ ram + dup c@ 1+ FF and dup -rot swap c! dup                       
  flag-z ! 80 and flag-n !  1 reg-pc+ 3 cycle+ ;                                     
: doldy ( LDY aa )                                                                   
  reg-pc @ >rom c@ dup dup reg-y ! flag-z ! 80 and flag-n !                          
  1 reg-pc+ 2 cycle+ ; 
: doldx ( LDX #aa )                                                                  
  reg-pc @ >rom c@ dup dup reg-x ! flag-z ! 80 and flag-n !                          
  1 reg-pc+ 2 cycle+ ;                                                               
: dobne ( BNE <aa )                                                                  
  flag-z @ if reg-pc @ >rom cs@ 1+ reg-pc+ else 1 reg-pc+ then                       
  3 cycle+ ;                                                                         
: 6502emu ( cycles -- )                                                              
  begin cycle @ over  < while                                                        
    reg-pc @ >rom c@ 1 reg-pc+                                                       
    dup 4C = if dojmp then      dup A5 = if dolda then                               
    dup 85 = if dosta then      dup F0 = if dobeq then                               
    dup D0 = if dobne then      dup A9 = if doldai then                              
    dup CA = if dodex then      dup 88 = if dodey then                               
    dup E6 = if doinc then      dup A0 = if doldy then                               
        A2 = if doldx then      repeat drop ; 

create testcode                                                                      
  A9 c, 00 c,  \ start: LDA #0                                                       
  85 c, 08 c,  \        STA 08                                                       
  A2 c, 0A c,  \        LDX #10                                                      
  A0 c, 0A c,  \ loop1: LDY #10                                                      
  E6 c, 08 c,  \ loop2: INC 08                                                       
  88 c,        \        DEY                                                          
  D0 c, FB c,  \        BNE loop2                                                    
  CA c,        \        DEX                                                          
  D0 c, F6 c,  \        BNE loop1                                                    
  4C c, 00 c, 80 C, \   JMP start 
                                                     
: init-vm 13 0 do i testcode + c@ i rom + c! loop                                    
          0 cycle ! 8000 reg-pc ! ;                                                  

: bench6502 100 0 do init-vm &6502 6502emu loop ;

Rainer Glaschick hat einen Benchmark für das Collatz-Problem erstellt. Die Wikipedia über das Collatz-Problem: https://de.wikipedia.org/wiki/Collatz-Problem

Dieser Benchmark bricht ab, wenn die Zahlen fuer ein 16bit Forth zu gross werden.

( Benchmark mit der Collatz-Funktion  V1.1 RG 2017-10-05   )
(   c[n+1] = if even(c[n]) then c[n]/2 else 3*c[n]+1 fi    )
( Da der zweite Term immer gerade ist, wird                )
(   c[n+1] = if odd(c[n]) then c[n]/2 else (3*c[n]+1)/2 fi )
( Seien r[n] der Rest und q[n] der Quotient von c[n]/2,    )
( also c[n] = 2*q[n] + r[n], somit bei r[n] = 1:           )
( (3*c[n]+1)/2 = 3*q[n] + 2                                )
( Diese Version fuer 16-bit Rechner prueft vor einem       )
( Ueberlauf und bricht die Folge ab:                       )
( Damit 3*q+2<32767 ist, muss q<10922 sein.                )

( Collatz-Schritt. Null wenn Ueberlauf )
: cn+1 		( cn -- cm )
  2 /mod swap			
  if dup 10922 < 	( kein ueberlauf ? )
    if 3 * 2 + 
    else drop 0 then
  then
;
 
( Collatz-Folge drucken                         )
( dieses Wort wird im Benchmark nicht benoetigt )
( es druckt die Collatz-Folge aus               )

: coll. 	( cn -- )
  begin dup 1 > while
    cn+1 dup .
  repeat
  drop		( always 1 )
;
 
( Collatz-Folge zaehlen. Null wenn Ueberlauf )
: ccnt 		( cn -- cnt)
  0 swap 	( cnt cn )
  begin dup 1 > while
  cn+1 dup 
	if swap 1 + swap ( zaehlen )
	else drop 0
	then
  repeat
  drop
;
 
\ Maximum fuer alle Folgen bis k bestimmen
: cmax 		( k -- max )
  0 swap	( max k )
  begin dup 0 > while
    dup ccnt 	( max k cnt )
    rot  	( k cnt max )
    max		( k max )
    swap	( max k )
    1 -		( max k-1 )
  repeat
  drop
;

( Funktionstest, Ergebniss muss die Zahl "126" sein )
32101 cmax .
." = 126 ! "
 
( Benchmark-Schleife fuer schnelle Rechner > ~200Mhz )
: bench
  99 0 do 32101 cmax drop loop
;

Ein Benchmark für 8bit Mikrocontroller, angeregt in Vierte Dimension 03/93 von Rafael Deliano

HEX 
5 CONSTANT FIVE 
VARIABLE BVAR 

: BENCH 
  100 0 DO 
    1 BEGIN 
        DUP SWAP 
        DUP ROT DROP 
        1 AND IF 
          FIVE + 
        ELSE 
          1- 
        THEN 
        BVAR ! BVAR @ 
        DUP 0100 AND 
     UNTIL DROP 
   LOOP ;

A Palindrome numbers filtering prepared by Francois Laagel

Tested with GNU/Forth and Z79Forth.

\ Palindrome numbers filtering [10..50000]. FLA Dec 10, 2020

: num>str ( n -- addr bytecount ) 0 <# #S #> ;

: lasteqfirst? ( addr offsetlast -- flag )
  OVER + C@ SWAP C@ = ;

: ispalindrome? ( addr offsetlast -- flag )
  DUP 1 <              IF 2DROP 1 EXIT THEN
  2DUP lasteqfirst? 0= IF 2DROP 0 EXIT THEN
  2 - SWAP 1+ SWAP RECURSE ;

: pal ( -- ) CR 10 BEGIN
    DUP   num>str  \ n\addr\bcount
    2DUP 1-        \ n\addr\bcount\addr\bcount-1
    ispalindrome?  \ n\addr\bcount\flag
    IF TYPE SPACE
    ELSE 2DROP THEN
    1+ DUP 50000 =
  UNTIL DROP ;