Continuing my concatenative language kick, I’ve been having fun playing with Retro (http://www.retroforth.com) and couldn’t resist making an F#-based VM on which to run it. It is an elegant, minimal Forth with an important twist. What caught my eye is that it supports quotations and combinators much like Joy, Cat, Factor, ... I may have to add this to TransForth, and I may have to do a follow up post to “Programming is Pointless” showing off the beauty of quotations and combinators in a pure composition-based world.

## Stop Thinking About the Stack

Quotations allow you to push anonymous functions to the stack and combinators are words taking functions as input. Here’s just one example (in Factor, taken from
Aaron Schaefer’s blog) of how they change the flavor of your code.  To find the average of a sequence of numbers we could:

{ 1 2 3 } dup sum swap length / .

Push a list of numbers, dup the list so that we can sum one copy, then swap and get the length of the other. Finally divide the sum by the length and display the result. This works fine, but with stack shuffling words like dup and swap, you have to keep the stack in mind. I would rather put that out of my mind and more directly express the intent:

{ 1 2 3 } [ sum ] [ length ] bi / .

The square brackets delimit quotations, treated as data. Here they contain single words but could just as easily contain longer sequences; something like anonymous functions. The
bi word then consumes the list of numbers and the two quotations, applying each quotation to the list, leaving the sum and length to be consumed by /. This isn’t necessarily more concise, but it is certainly more direct without any stack juggling.

## The Ngaro VM (in F#)

Retro runs on a tiny VM called
Ngaro which has been ported to a growing list of languages and platforms – C, Python, Ruby, ANS Forth, C#, Common Lisp, Go, Java, Lua, Perl, Javascript, .... Missing from the list was F# (and as for .NET in general, the C# version was incomplete). I went ahead and made my own implementation (below) and submitted it back to the project. I like that for concision, the only implementation that beats this F# one is the one in Lisp – only slightly and it’s lacking file I/O features :-)

To use it, just grab the latest
retroImage and drop it in the same directory. Like any respectable Forth, Retro is written in Retro of course and can compile itself. You can grab the source (core.rx) in the latest release, make tweaks and run the VM below “--with core.rx” to compile a new image. There are lots of interesting samples and libraries as well. Have fun!

open System

open System.IO

open System.Text

let MEM_SIZE = 1024 * 1024

let IMAGE_FILE = "retroImage"

let MAX_OPEN_FILES = 8

let PORTS = 12

let mutable ip = 0

let mutable ports = Array.create PORTS 0

let mutable inputs = Array.create PORTS ""

let mutable memory = Array.create MEM_SIZE 0

let mutable (files : FileStream[]) = Array.create MAX_OPEN_FILES null

let mutable isp = 0

let mutable offset = 0

let mutable shrink = false

let mutable halt = false

let data = ref []

let pushVal d x = d := x :: !d

let popVal d () = match !d with h :: t -> d := t; h | _ -> failwith "Underflow"

let push = pushVal data

let pop = popVal data

for i in 0 .. int (binReader.BaseStream.Length / 4L) - 1 do

let saveImage () =

let j = if shrink then memory.[3] else MEM_SIZE

use binWriter = new BinaryWriter(File.Open(IMAGE_FILE, FileMode.Create))

Array.iter (fun (c : int) -> binWriter.Write(c)) memory.[0..j - 1]

let key () =

if isp > 0 && offset = inputs.[isp].Length - 1 then // Next input source?

isp <- isp - 1

offset <- 0

if isp > 0 then // Read from a file

offset <- offset + 1

int inputs.[isp].[offset]

if cki.Key = ConsoleKey.Backspace then printf "\b "

int cki.KeyChar

let devices () =

let getString () =

let s = pop ()

let e = Array.FindIndex(memory, s, fun c -> c = 0)

new String(Array.map char memory.[s .. e - 1])

let openFile () =

let handle = Array.findIndex ((=) null) files |> ((+) 1)

let mode, name = pop (), getString ()

try

match mode with

| 0 -> files.[handle] <- File.Open(name, FileMode.Open)

| 1 -> files.[handle] <- File.Open(name, FileMode.OpenOrCreate)

| 2 -> files.[handle] <- File.Open(name, FileMode.Append)

| 3 -> let f = File.Open(name, FileMode.Open)

f.Seek(0L, SeekOrigin.End) |> ignore

files.[handle] <- f

| _ -> failwith "Invalid mode"

handle

with _ -> 0

if c = -1 then 0 else c

let writeFile h = pop () |> byte |> files.[h].WriteByte; 1

let closeFile h =

let f = files.[h]

if f <> null then

f.Close()

f.Dispose()

files.[h] <- null

0

let getFilePos h = int files.[h].Position

let setFilePos h = files.[h].Seek(pop () |> int64, SeekOrigin.Begin) |> int

let getFileSize handle = files.[handle].Length |> int

let deleteFile name = if File.Exists name then File.Delete name; -1 else 0

if ports.[0] <> 1 then

ports.[0] <- 1

if ports.[1] = 1 then ports.[1] <- key () // Read from input source

if ports.[2] = 1 then

let x = pop ()

if x < 0 then Console.Clear()

else Console.Write(char x)

ports.[2] <- 0

if ports.[3] = 1 then ports.[3] <- 0 // Video update

match ports.[4] with

| 1 -> saveImage () ; ports.[4] <- 0 // Save Image

| 2 -> // Add to Input Stack

isp <- isp + 1

ports.[4] <- 0

| -1 -> ports.[4] <- openFile ()

| -2 -> ports.[4] <- pop () |> readFile

| -3 -> ports.[4] <- pop () |> writeFile

| -4 -> ports.[4] <- pop () |> closeFile

| -5 -> ports.[4] <- pop () |> getFilePos

| -6 -> ports.[4] <- pop () |> setFilePos

| -7 -> ports.[4] <- pop () |> getFileSize

| -8 -> ports.[4] <- getString () |> deleteFile

| _ -> ports.[4] <- 0

ports.[5] <- match ports.[5] with // Capabilities

| -1 -> MEM_SIZE

| -5 -> (!data).Length // stack depth

| -8 -> int (DateTime.UtcNow - new DateTime(1970,1,1)).TotalSeconds

| -9 -> halt <- true; 0

| -10 -> // Query for environment variable

let var = getString ()

let name = ref (pop ())

Array.iter (fun element ->

memory.[name.Value] <- int element

name := name.Value + 1)

(var |> Environment.GetEnvironmentVariable

|> Encoding.ASCII.GetBytes)

0

| -11 -> Console.WindowWidth

| -12 -> Console.WindowHeight

| _ -> 0

let rec exec () =

let dyadic fn = let x = pop () in fn (pop ()) x |> push

let dyadic2 fn = let x, y = fn (pop ()) (pop ()) in push y; push x

let incIp () = ip <- ip + 1

let condJump fn =

let x = pop ()

if fn (pop ()) x then ip <- memory.[ip + 1] - 1 else incIp ()

let jump () =

ip <- memory.[ip] - 1

if memory.[ip + 1] = 0 then incIp ()

if memory.[ip + 1] = 0 then incIp ()

let drop () = pop () |> ignore

let loop () =

pop () - 1 |> push

if tos () > 0 then ip <- memory.[ip + 1] - 1

else incIp (); drop ()

if not halt then

match memory.[ip] with

| 0 -> () // NOP

| 1 -> incIp (); memory.[ip] |> push // LIT

| 2 -> tos () |> push // DUP

| 3 -> drop () // DROP

| 4 -> dyadic2 (fun x y -> y, x) // SWAP

| 5 -> pop () |> pushr // PUSH

| 6 -> popr () |> push // POP

| 7 -> loop () // LOOP

| 8 -> incIp (); jump () // JUMP

| 9 -> ip <- popr () // RETURN

| 10 -> condJump (>) // GT_JUMP

| 11 -> condJump (<) // LT_JUMP

| 12 -> condJump (<>) // NE_JUMP

| 13 -> condJump (=) // EQ_JUMP

| 14 -> memory.[pop ()] |> push // FETCH

| 15 -> memory.[pop ()] <- pop () // STORE

| 17 -> dyadic (-) // SUB

| 18 -> dyadic (*) // MUL

| 19 -> dyadic2 (fun x y -> y / x, y % x) // DIVMOD

| 20 -> dyadic (&&&) // AND

| 21 -> dyadic (|||) // OR

| 22 -> dyadic (^^^) // XOR

| 23 -> dyadic (<<<) // SHL

| 24 -> dyadic (>>>) // SHR

| 25 -> if tos () = 0 then drop (); ip <- popr () // ZERO_EXIT

| 26 -> pop () + 1 |> push // INC

| 27 -> pop () - 1 |> push // DEC

| 28 -> let x = pop () in ports.[x] |> push; ports.[x] <- 0  // IN

| 29 -> ports.[pop ()] <- pop () // OUT

| 30 -> devices () // WAIT

| _ -> pushr ip; jump ()

ip <- ip + 1

exec ()

let args = Environment.GetCommandLineArgs()

Array.iteri

(fun i arg ->

match arg with

| "--shrink" -> shrink <- true

| "--about" -> printfn "Retro Language [VM: F#, .NET]"

| "--with" ->

isp <- isp + 1

| _ -> ()

) args