Forth examples


Fibonacci numbers
\ fib ( x -- , returns first x numbers in Fibonacci sequence )

: fib { x -- }                 \ local index variable x
   1 dup .                     \ initialize sequence & print initial values
   1 dup . 
   begin
     over over +               \ add previous 2 numbers in sequence
     dup . rot drop            \ add new number to stack, drop bottom number
     x 1- dup -> x 3 <         \ decrement x, exit if x < 3
   until
   drop drop                   \ drop top 2 elements off stack
; 

Sorting algorithms
variable sorted           \ flag variable signals if list is sorted

: sorted? { | a -- }      \ checks stack, sets sorted TRUE or FALSE
   depth 1 =              \ if stack has only one element,
   if 1 sorted !          \   return TRUE
   else
     over over < not      \ else, if top two elements are in sorted order,
     if -> a recurse a    \   check rest of stack
     else 0 sorted !      \ else (top is out of order) return FALSE
     then
   then
;

: bubble.aux { | a -- }   \ recursive bubble sort
  over over <             \ if top two numbers are out of order,
  if  swap then           \   swap them
  depth 2 >               \ if there are more than two numbers on stack,
  if -> a recurse a       \   bubble.aux the stack minus top number
  then
;

: bubble                  \ front-end for bubble.aux
  begin
    bubble.aux
    sorted? sorted @      \ call bubble.aux until list is sorted
  until
  begin
    . depth 0 > not         \ empty and print stack
  until
;

: sort.aux { | a -- }     \ recursive sort
  depth 2 >               \ if more than two numbers on stack,
  if over over <          \   
    if swap then          \
    rot over over <       \
    if swap then          \
    -> a                  \   store smallest of top 3 numbers in a,
    recurse a             \   sort.aux rest of stack, add a to top
  else over over <        \ else make sure bottom 2 numbers are sorted
    if swap then
  then
;

: sort
  begin
    sort.aux
    sorted? sorted @      \ call sort.aux until sorted
  until
  begin
    . depth 0 > not       \ empty and print stack
  until
;