[The third in a series of posts on the evolution of TransForth]

Now that we have Forth hobbling along, we can start to peel away the scaffolding. Some of the things we’ve defined in F# can now be redefined in Forth instead. As we go along, I think you’ll be amazed by just how little it takes to bootstrap a Forth system. Also, with just a few more primitives we can really start to build things up.

 

Trimming Fat

 

To start with a silly one, we don’t strictly need to define subtraction:

 

dyadic (-) |> define "-"

 

In the last post we defined : NEGATE   -1 * ; and we can define subtraction as adding the negative : -   NEGATE + ;

 

We had also defined a bunch of stack manipulation primitives:

 

let stk fn () = stack <- fn stack

define "DUP" (stk (function x :: t -> x :: x :: t | _ -> underflow ()))

define "SWAP" (stk (function x :: y :: t -> y :: x :: t | _ -> underflow ()))

define "OVER" (stk (function (x :: y :: _ as t) -> y :: t | _ -> underflow ()))

define "ROT" (stk (function x::y::z::t -> z::x::y::t | _ -> underflow ()))

 

… but really these (and more) can all be defined in terms of PICK and ROLL:

 

: DUP    0 PICK ;

: OVER   1 PICK ;

: SWAP   1 ROLL ;

: ROT    2 ROLL ;

: 2DROP  DROP DROP ;

: 2DUP   OVER OVER ;

: 2OVER  3 PICK 3 PICK ;

: 3DUP   DUP 2OVER ROT ;

 

One NAND To Rule Them All

 

Just as NAND gates can serve as the basis for all other types of logic gates (so can NOR), we really only need one primitive to build up all the bitwise operators:

 

dyadic (fun a b -> ~~~(a &&& b)) |> define "NAND" // basis of NOT, OR, XOR, ...

 

From this we can get:

 

: NOT  DUP NAND ;

: AND  NAND NOT ;

: OR   NOT SWAP NOT NAND ;

: NOR  OR NOT ;

: XOR  2DUP AND -ROT NOR NOR ;

: XNOR XOR NOT ;

 

Interesting also, is that Forth represents truth as -1 (all bits on - as opposed to using any ol’ non-zero), so the above also serve as logical operators.

 

Comparison Primitives

 

We have yet to build conditional operators (next post), but we can go ahead and define comparison:

 

let comp fn = dyadic (fun a b -> if fn a b then -1 else 0)

comp (>) |> define ">"

comp (=) |> define "="

 

From this we can build more of the standard Forth words:

 

: <     2DUP > -ROT = OR NOT ;
: <=    2DUP < -ROT = OR ;
: >=    2DUP > -ROT = OR ;
: <>     = NOT ;

: 0>    0 > ;

: 0=    0 = ;

: 0<    0 < ;

: 0<>   0 <> ;

 

Comments

 

It’s been bugging me that we don’t have comment, so let’s throw that in too. They can be in the form ( this is a comment ) or can \ run to the end of the line

 

let comment term () = source <- Seq.skipWhile ((<>) term) source |> Seq.skip 1

comment '\n' |> define "\\"; immediate ()

comment ')' |> define "("; immediate ()

 

Library

 

Here’s the latest library all together. A few other things have been added such as /MOD and a bunch of increment/decrement and shift words: 1+ 1- 2+ 2- 2* 2/. The reason for these simple words is not just to save typing a space. It's because once we target real hardware they may be defined in terms of efficient machine-level instructions. For example 2* and 2/ really are bit shifts.

 

rep "

: NEGATE   -1 * ; 

: SQUARE  ( a -- a^2)  DUP * ;

: CUBE  ( a -- a^3)  DUP DUP * * ;

: /MOD  ( a b -- rem quot)  2DUP MOD -ROT / ;

 

: DUP  ( a -- a a)  0 PICK ;

: OVER  ( a b -- a b a)  1 PICK ;

: SWAP  ( a b -- b a)  1 ROLL ;

: ROT  ( a b c -- b c a)  2 ROLL ;

: -ROT  ( a b c -- c a b)  ROT ROT ;

: NIP  ( a b -- b)  SWAP DROP ;

: TUCK  ( a b -- b a b)  SWAP OVER ;

 

: 2DROP  ( a b -- )  DROP DROP ;

: 2DUP  ( a b -- a b a b)  OVER OVER ;

: 2OVER  ( a b c d -- a b c d a b)  3 PICK 3 PICK ;

: 3DUP  ( a b c -- a b c a b c)  DUP 2OVER ROT ;

 

: -  ( a b -- diff)  NEGATE + ;

 

: 1+ 1 + ;

: 1- 1 - ;

: 2+ 2 + ;

: 2- 2 - ;

: 2* 2 * ;

: 2/ 2 / ;

 

: TRUE  ( -- t)  -1 ; \ normally constant

: FALSE  ( -- f)  0 ; \ normally constant

: NOT  ( a -- ~a)  DUP NAND ;

: AND  ( a b -- a&b)  NAND NOT ;

: OR  ( a b -- a|b)  NOT SWAP NOT NAND ;

: NOR  ( a b -- ~a|b)  OR NOT ;

: XOR  ( a b -- a^b)  2DUP AND -ROT NOR NOR ;

: XNOR ( a b -- ~a^b)  XOR NOT ;

 

: <  ( a b -- a<b)  2DUP > -ROT = OR NOT ;

: <= ( a b -- a<=b) 2DUP < -ROT = OR ;

: >= ( a b -- a>=b) 2DUP > -ROT = OR ;

: <>  ( a b -- ?)  = NOT ;

: 0>   0 > ;

: 0=   0 = ;

: 0<   0 < ;

: 0<>   0 <> ;

"

 

New Tests

 

case "22 4 /MOD . ." "5 2 " // quotient and remainder

case "7 \ comment\n 8 .S" "7 8 " // comment skipped

case "7 ( comment ) 8 .S" "7 8 " // comment skipped

case "1 2 3 2DROP .S" "1 " // drop pair

case "1 2 3 2DUP .S" "1 2 3 2 3 " // dup pair

case "1 2 3 4 2OVER .S" "1 2 3 4 1 2 " // over pairs

case "1 2 3 3DUP .S" "1 2 3 1 2 3 " // dup tripple

case "42 1+ ." "43 " // increment

case "42 1- ." "41 " // decrement

case "42 2+ ." "44 " // double inc

case "42 2- ." "40 " // double dec

case "42 2* ." "84 " // left shift

case "42 2/ ." "21 " // right shift

case "TRUE ." "-1 " // true constant

case "FALSE ." "0 " // false constant

case "0 0 NAND ." "-1 " // nand

case "0 -1 NAND ." "-1 " // nand

case "-1 0 NAND ." "-1 " // nand

case "-1 -1 NAND ." "0 " // nand

case "0 NOT ." "-1 " // not

case "-1 NOT ." "0 " // not

case "0 0 AND ." "0 " // and

case "0 -1 AND ." "0 " // and

case "-1 0 AND ." "0 " // and

case "-1 -1 AND ." "-1 " // and

case "0 0 OR ." "0 " // or

case "0 -1 OR ." "-1 " // or

case "-1 0 OR ." "-1 " // or

case "-1 -1 OR ." "-1 " // or

case "0 0 NOR ." "-1 " // nor

case "0 -1 NOR ." "0 " // nor

case "-1 0 NOR ." "0 " // nor

case "-1 -1 NOR ." "0 " // nor

case "0 0 XOR ." "0 " // xor

case "0 -1 XOR ." "-1 " // xor

case "-1 0 XOR ." "-1 " // xor

case "-1 -1 XOR ." "0 " // xor

case "0 0 XNOR ." "-1 " // xnor

case "0 -1 XNOR ." "0 " // xnor

case "-1 0 XNOR ." "0 " // xnor

case "-1 -1 XNOR ." "-1 " // xnor

case "42 6 > ." "-1 " // greater

case "6 42 > ." "0 " // greater

case "6 6 > ." "0 " // greater

case "-1 0> ." "0 " // greater than zero

case "0 0> ." "0 " // greater than zero

case "1 0> ." "-1 " // greater than zero

case "6 42 = ." "0 " // equal

case "6 6 = ." "-1 " // equal

case "42 6 < ." "0 " // less

case "6 42 < ." "-1 " // less

case "6 6 < ." "0 " // less

case "42 6 <= ." "0 " // less or equal

case "6 42 <= ." "-1 " // less or equal

case "6 6 <= ." "-1 " // less or equal

case "42 6 <> ." "-1 " // not equal

case "6 42 <> ." "-1 " // not equal

case "6 6 <> ." "0 " // not equal

case "-1 0> ." "0 " // greater than zero

case "0 0> ." "0 " // greater than zero

case "1 0> ." "-1 " // greater than zero

case "42 0= ." "0 " // equal to zero

case "0 0= ." "-1 " // equal to zero

case "-1 0< ." "-1 " // less than zero

case "0 0< ." "0 " // less than zero

case "1 0< ." "0 " // less than zero

case "0 0<> ." "0 " // not equal to zero

case "42 0<> ." "-1 " // not equal to zero

 

Next>