[The Original Shootout]   [NEWS]   [FAQ]   [Methodology]   [Platform Details]   [Acknowledgements]   [Scorecard]
All Source For bigforth
Ackermann's Function
```\ \$Id: ackermann.bigforth,v 1.2 2001/06/25 00:34:05 doug Exp \$
\ ackermann's function
\ http://www.bagley.org/~doug/shootout/
\ from James Hague

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

: ack
over 0=
if nip 1+
else
dup 0=
if drop 1- 1 recurse
else
1- over swap recurse  swap 1- swap recurse
then
then ;

\ run ack(3, NUM) and print result from stack
." Ack: " 3 NUM ack 1 u.r cr

bye
```
Array Access
```\ \$Id: ary3.bigforth,v 1.1 2001/06/19 16:20:45 doug Exp \$
\ http://www.bagley.org/~doug/shootout/

decimal

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

variable X
NUM cells allocate drop X !
variable Y
NUM cells allocate drop Y !

: ary
NUM 0 do
1 i + i cells X @ + !
loop
1000 0 do
NUM 0 do
i cells Y @ +
dup @
i cells X @ +
@ + swap !
loop
loop ;

ary

Y @ @ 1 u.r ."  " NUM 1 - cells Y @ + @ 1 u.r cr

bye \ th-th-that's all folks!
```
Count Lines/Words/Chars
```\ -*- mode: forth -*-
\ \$Id: wc.bigforth,v 1.1 2001/06/24 22:27:35 doug Exp \$
\ http://www.bagley.org/~doug/shootout/

variable  nn       0       nn !       \ number of newlines
variable  nw       0       nw !       \ number of words
variable  nc       0       nc !       \ number of chars
variable  in_word  0       in_word !  \ flag: "in word"

10  constant  nl_ch
9   constant  tab_ch
32  constant  space_ch

\ scan the buffer and count lines, words, chars
: scanbuff
dup nc +!                 \ update nc with amount of chars in buffer
buff + buff           \ from start of buff to buff + n
do
i c@
case
nl_ch    of  0 in_word !  1 nn +!  endof
tab_ch   of  0 in_word !  endof
space_ch of  0 in_word !  endof
\ otherwise:
in_word @ 0=
if
1 in_word !
1 nw +!
then
endcase
loop ;

: wc
buff
begin
while
scanbuff
repeat ;

wc nn @ . nw @ . nc @ 1 u.r cr

bye \ th-th-that's all folks!
```
Exception Mechanisms
```\ -*- mode: forth -*-
\ \$Id: except.bigforth,v 1.1 2001/06/20 19:04:07 doug Exp \$
\ http://www.bagley.org/~doug/shootout/
\ from Anton Ertl

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

1 constant *hi*
2 constant *lo*

variable lo
variable hi

: blowup
1 and if
*lo* throw
else
*hi* throw
then ;

: lo-function
['] blowup catch
dup *lo* <> tuck and throw
1+ lo +! ;

: hi-function
['] lo-function catch
dup *hi* <> tuck and throw
1+ hi +! ;

: some-function
['] hi-function catch abort" We shouldn't get here" ;

: main
NUM 0 ?do
i some-function drop
loop
." Exceptions: HI=" hi ? ." / LO=" lo @ 1 u.r cr ;

main bye
```
Fibonacci Numbers
```\ \$Id: fibo.bigforth,v 1.1 2001/06/19 16:20:46 doug Exp \$
\ fibonacci numbers
\ http://www.bagley.org/~doug/shootout/

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

\ compute fibonacci numbers
: fib  recursive
dup 2 <
if
drop 1
else
dup
2 - fib
swap
1 - fib
+
then ;

NUM fib 1 u.r cr

bye \ th-th-that's all folks!
```
Hello World
```\ \$Id: hello.bigforth,v 1.1 2001/06/19 16:20:46 doug Exp \$
\ http://www.bagley.org/~doug/shootout/

." hello world" cr bye
```
List Operations
```\ -*- mode: forth -*-
\ \$Id: lists.bigforth,v 1.1 2001/06/19 16:20:46 doug Exp \$
\ http://www.bagley.org/~doug/shootout/
\ from Anton Ertl

0. argc @ 1- arg >number 2drop drop constant NUM

10000 constant SIZE

struct
cell% field list-next
cell% field list-val
end-struct list%

: make-list
0 0 SIZE -do
list% %alloc
i over list-val !
tuck list-next !
1 -loop
;

: copy-list
0 { w^ list2 }
list2 begin
over
while
list% %alloc dup >r swap !
dup list-val @ r@ list-val !
list-next @ r> list-next
repeat
off drop list2 @ ;

\ somehow this is an expensive noop
0 { w^ list2 }
list2 begin
over
while
\ move one element
over list-next dup @ 2>r
over list-next off
! r> r>
repeat
off drop list2 @ ;

: nreverse
\ destructive reverse
0 swap begin
dup
while
dup list-next @ >r
tuck list-next ! r>
repeat
drop ;

: move-tail-to-tail

: list-equals
begin
dup
while
over
while
over list-val @ over list-val @ <> if
2drop false exit
endif
list-next @ swap list-next @
repeat then
= ;

: list-length
0 begin
over
while
1+ swap list-next @ swap
repeat
nip ;

s" wrong result" exception constant wrong-result

: main
0 NUM 0 ?do
drop
make-list dup copy-list
dup list-val @ SIZE <> wrong-result and throw
tuck list-equals 0= wrong-result and throw
list-length
loop ;

main 0 .r cr bye

```
Method Calls
```\ -*- mode: forth -*-
\ \$Id: methcall.bigforth,v 1.2 2001/06/24 23:22:53 doug Exp \$
\ http://www.bagley.org/~doug/shootout/

\ from Bernd Paysan:
\ I'm using oof.fs here (native OOF for bigforth), code using one of
\ the other OO Forth extensions will look different.

0. argc @ 1- arg >number 2drop drop constant NUM

include oof.fb

object class Toggle
cell var state
public:
method activate
method value
how:
: init   state ! ;
: value   state @ ;
: activate   state @ invert state ! ;
class;

Toggle class NthToggle
cell var count-max
cell var counter
how:
: init
super init  count-max ! 0 counter ! ;
: activate
1 counter +!
counter @ count-max @ >= if
state @ invert state !
0 counter !
then ;
class;

: flag.
if ." true" else ." false" then cr ;

: mainloop
true NUM 0 ?do
drop dup toggle with activate value endwith
loop
flag.  drop ;

: main
true Toggle new mainloop
3 true NthToggle new mainloop ;

main bye
```
Nested Loops
```\ \$Id: nestedloop.bigforth,v 1.1 2001/06/19 16:20:46 doug Exp \$
\ http://www.bagley.org/~doug/shootout/

decimal

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

: nestedloops
NUM 0 do
NUM 0 do
NUM 0 do
NUM 0 do
NUM 0 do
NUM 0 do
1+
loop
loop
loop
loop
loop
loop ;

\ run test and print result
0 nestedloops 1 u.r cr

bye \ th-th-that's all folks!
```
Object Instantiation
```\ -*- mode: forth -*-
\ \$Id: objinst.bigforth,v 1.3 2001/06/25 20:54:09 doug Exp \$
\ http://www.bagley.org/~doug/shootout/

\ from Bernd Paysan:
\ I'm using oof.fs here (native OOF for bigforth), code using one of
\ the other OO Forth extensions will look different.

0. argc @ 1- arg >number 2drop drop constant NUM

include oof.fb

object class Toggle
cell var state
public:
method activate
method value
how:
: init   state ! ;
: value   state @ ;
: activate   state @ invert state ! ;
class;

Toggle class NthToggle
cell var count-max
cell var counter
how:
: init
super init  count-max ! 0 counter ! ;
: activate
1 counter +!
counter @ count-max @ >= if
state @ invert state !
0 counter !
then ;
class;

: flag.
if ." true" else ." false" then cr ;

: mainloop
true swap 0 ?do
drop dup toggle with activate value endwith dup flag.
loop
drop ;

: main
true Toggle new 5 mainloop
NUM 0 ?do
true Toggle new toggle with dispose endwith \ like the C version
loop
cr
3 true NthToggle new 8 mainloop
NUM 0 ?do
3 true NthToggle new toggle with dispose endwith \ like the C version
loop ;

main bye
```
```\ \$Id: prodcons.bigforth,v 1.1 2001/06/20 20:55:43 doug Exp \$
\ http://www.bagley.org/~doug/shootout/
\ from Bernd Paysan

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

Variable count
Variable data
Variable produced
Variable consumed

\ note: no mutex is needed here. bigFORTH's tasker is cooperative
\ and switches tasks only with PAUSE.

: producer
up@ swap 2 \$1000 dup NewTask pass
0 ?DO
BEGIN  count @ 1 =  WHILE  pause  REPEAT
1 count ! I data !
1 produced +!
LOOP wake ;

: consumer
up@ swap 2 \$1000 dup NewTask pass
0 swap 0 ?DO
BEGIN  count @ 0=  WHILE  pause  REPEAT
0 count ! drop data @
1 consumed +!
LOOP drop wake ;

NUM producer
NUM consumer

\ There is no "main" task - to synchronize, each of the two new
\ when they are done. The main task therefore has to stop twice
\ (and wait to be woken up)

stop stop

produced @ .
consumed @ 1 u.r cr

bye \ th-th-that's all folks!
```
Random Number Generator
```\ -*- mode: forth -*-
\ \$Id: random.bigforth,v 1.1 2001/06/20 23:23:29 doug Exp \$
\ http://www.bagley.org/~doug/shootout/
\ based on code from Marcel Hendrix

\needs float  import float  float also

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

139968     CONSTANT IM
3877     CONSTANT IA
29573     CONSTANT IC
IM S>D D>F
1e FSWAP F/ FCONSTANT FIM
42     VALUE seed

: format-float  ff\$ type ;

: IM_mod
S" DUP \$001DF757 UM* NIP  \$FFFFFFC0 AND  2187 *  - "
EVALUATE ; IMMEDIATE

: gen_random
S" seed IA *  IC +  IM_mod  DUP TO seed 0 D>F " EVALUATE
S" FIM F* F* " EVALUATE ; IMMEDIATE

: MAIN
NUM
10 SET-PRECISION
0e  BEGIN  ?DUP
WHILE  1- FDROP 100e0 gen_random
REPEAT
format-float cr ;

MAIN
bye
```
Reverse a File
```\ -*- mode: forth -*-
\ \$Id: reversefile.bigforth,v 1.2 2001/06/24 22:53:06 doug Exp \$
\ http://www.bagley.org/~doug/shootout/

\ Idea by albert@spenarnc.xs4all.nl (Albert van der Horst) in
\ news:<GFDtFA.Lwz.1.spenarn@spenarnc.xs4all.nl>

2000000 constant size \ maximum size of input
size allocate throw constant buf
4096 constant linesize
create line linesize 2 + allot

: revfile   >r
line buf size + begin
1-
while  \ !! handle line buf overflows
>r #lf over c!
r@ - 2dup r> move
repeat
drop nip 1+ buf size + over -  rdrop ;

stdin revfile type bye
```
Sieve of Erathostenes
```\ \$Id: sieve.bigforth,v 1.1 2001/06/19 16:20:46 doug Exp \$
\ http://www.bagley.org/~doug/shootout/
\ adapted from a program in the gforth distribution
\ modified and annotated by doug bagley

\ find and count all primes from 2 to 8192

decimal

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

\ we search for primes up to this SIZE
8192 constant SIZE

\ Flags is an array of chars of length SIZE
\ we'll mark all non-prime indexes in this array as false
\ the remaining indexes will be prime numbers
create Flags SIZE allot

\ EndFlags points to end of array Flags
Flags SIZE + constant EndFlags

\ FLAGMULTS
\ flag all multiples of n in array as not prime
\ starting value for fromaddr should be
\   arraystart n n + +
: flagmults
do
0 i c! dup
+loop ;
\ END FLAGMULTS

\ PRIMES
\ find all primes from 2 to SIZE
: primes
\ fill array Flags with 1's
Flags SIZE 1 fill
0 2
\ index i ranges from Flags to EndFlags
EndFlags Flags
do
i c@
\ If the current Flags[i] is true (i.e. i is prime)
if
dup i + dup EndFlags <
\ If we aren't at end of flags array yet
if
EndFlags swap flagmults
else
drop
then
\ Increment our Count of Primes
swap 1+ swap
then
1+
loop
;
\ END PRIMES (Returns: Count)

\ BENCHMARK
\ run the test NUM times
: benchmark  0 NUM 0 do  primes nip loop ;

\ now print count of how many Flags are now "true"
." Count: " benchmark  1 u.r cr

\ PPRIMES
\ for testing, we can print out all the prime numbers
: pprimes
SIZE 0 do Flags i + c@ if i 2 + . then loop cr ;

\ uncomment the following to print the primes or debug
\ pprimes
\ flags 100 dump

bye \ th-th-that's all folks!
```
String Concatenation
```\ -*- mode: forth -*-
\ \$Id: strcat.bigforth,v 1.2 2001/06/24 17:08:56 doug Exp \$
\ http://www.bagley.org/~doug/shootout/

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

variable hsiz    32                       hsiz !  \ buffer can hold this much
variable hbuf    hsiz @ allocate throw    hbuf !  \ start of buffer
variable hoff    0                        hoff !  \ current offset in buffer

: STUFF s" hello." ;

: strcat
dup                              \ dup strlen on stack
hsiz @ hoff @ - >                \ if strlen > remaining space
if                               \ reallocate buffer
hsiz @ 2* hsiz !             \ double size
hbuf @ hsiz @ resize throw   \ reallocate buffer
hbuf !                       \ store (possibly new) buffer start
then
swap over                        \ stack: strlen straddr strlen
hbuf @ hoff @ +
swap cmove>                      \ append from straddr to hbuf+hoff
hoff @ + hoff !                  \ update hoff
;

: main
NUM 0
do
STUFF strcat
loop
\ as a final result push the resultant string on the stack as if we
\ were going to use it for something.
hbuf @ hoff @
\ and print out the length
1 u.r cr drop ;

main

bye \ th-th-that's all folks!
```
Sum a Column of Integers
```\ -*- mode: forth -*-
\ \$Id: sumcol.bigforth,v 1.1 2001/06/24 22:23:53 doug Exp \$
\ http://www.bagley.org/~doug/shootout/

256 constant max-line
create line-buffer max-line 1 + allot

: sumcol
0
begin
0.0 line-buffer