コード#コード#

40 constant arr_size

variable rand_state
utime d>s rand_state !

: rand ( -- )
	\ compiled code: ( -- n )
	]]
		rand_state @
		dup 13 lshift xor
		dup 7 rshift xor
		dup 17 lshift xor
		dup rand_state !
	[[
; immediate

: at_array ( -- )
	\ compiled code: ( a-addr u -- a-addr )
	]] cells + [[ ; immediate

: at_array@ ( -- )
	\ compiled code: ( a-addr u -- x ) 
	]] at_array @ [[ ; immediate

: swap_in_array ( -- )
	\ compiled code: ( a-addr u1 u2 -- )
	]] rot swap over swap cells + -rot swap cells + 2dup @ swap @ rot ! swap ! [[
; immediate

: qsort { array start end | left right pivot }
	start to left end to right
	array start end + 2 / at_array@ to pivot
	begin
		begin array left at_array@ pivot < while 1 +to left repeat
		begin array right at_array@ pivot > while -1 +to right repeat
		left right <= if
			array left right swap_in_array 1 +to left -1 +to right
		endif
	left right > until
	start right < if array start right recurse endif
	left end < if array left end recurse endif
;

: main ( -- )
	arr_size cells allocate throw { array }
	arr_size 0 +do i array i cells + ! loop
	arr_size 0 +do array rand abs arr_size mod i swap_in_array loop
	arr_size 0 +do array i at_array@ . loop cr
	array 0 arr_size 1 - qsort
	arr_size 0 +do array i at_array@ . loop
	array free
;

main

結果

2 6 12 4 3 24 27 36 35 14 0 19 13 30 11 33 10 18 20 9 26 32 22 21 31 37 1 34 28 39 16 38 23 17 5 29 15 8 25 7 
0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39