 # marionebl's solution

## to Forth in the OCaml Track

Published at Jul 09 2019 · 0 comments
Instructions
Test suite
Solution

#### Note:

This exercise has changed since this solution was written.

Implement an evaluator for a very simple subset of Forth.

Forth is a stack-based programming language. Implement a very basic evaluator for a small subset of Forth.

Your evaluator has to support the following words:

• `+`, `-`, `*`, `/` (integer arithmetic)
• `DUP`, `DROP`, `SWAP`, `OVER` (stack manipulation)

Your evaluator also has to support defining new words using the customary syntax: `: word-name definition ;`.

To keep things simple the only data type you need to support is signed integers of at least 16 bits size.

You should use the following rules for the syntax: a number is a sequence of one or more (ASCII) digits, a word is a sequence of one or more letters, digits, symbols or punctuation that is not a number. (Forth probably uses slightly different rules, but this is close enough.)

Words are case-insensitive.

## Getting Started

1. For library documentation, follow Useful OCaml resources.

## Running Tests

A `Makefile` is provided with a default target to compile your solution and run the tests. At the command line, type:

``````make
``````

## Submitting Incomplete Solutions

It's possible to submit an incomplete solution so you can see how others have completed the exercise.

## Feedback, Issues, Pull Requests

The exercism/ocaml repository on GitHub is the home for all of the Ocaml exercises.

If you have feedback about an exercise, or want to help implementing a new one, head over there and create an issue or submit a PR. We welcome new contributors!

### test.ml

``````open Base
open OUnit2
open Forth

let print_int_list_option (xs: int list option) = match xs with
| None -> "None"
| Some xs -> "Some [" ^ String.concat ~sep:";" (List.map ~f:Int.to_string xs) ^ "]"
let ae exp got _test_ctxt = assert_equal ~printer:print_int_list_option exp got

let parsing_and_numbers_tests = [
"numbers just get pushed onto the stack" >::
ae (Some [1; 2; 3; 4; 5]) (evaluate ["1 2 3 4 5"]);
]

ae (Some ) (evaluate ["1 2 +"]);
"errors if there is nothing on the stack" >::
ae None (evaluate ["+"]);
"errors if there is only one value on the stack" >::
ae None (evaluate ["1 +"]);
]

let subtraction_tests = [
"can subtract two numbers" >::
ae (Some [-1]) (evaluate ["3 4 -"]);
"errors if there is nothing on the stack" >::
ae None (evaluate ["-"]);
"errors if there is only one value on the stack" >::
ae None (evaluate ["1 -"]);
]

let multiplication_tests = [
"can multiply two numbers" >::
ae (Some ) (evaluate ["2 4 *"]);
"errors if there is nothing on the stack" >::
ae None (evaluate ["*"]);
"errors if there is only one value on the stack" >::
ae None (evaluate ["1 *"]);
]

let division_tests = [
"can divide two numbers" >::
ae (Some ) (evaluate ["12 3 /"]);
"performs integer division" >::
ae (Some ) (evaluate ["8 3 /"]);
"errors if dividing by zero" >::
ae None (evaluate ["4 0 /"]);
"errors if there is nothing on the stack" >::
ae None (evaluate ["/"]);
"errors if there is only one value on the stack" >::
ae None (evaluate ["1 /"]);
]

let combined_arithmetic_tests = [
ae (Some [-1]) (evaluate ["1 2 + 4 -"]);
"multiplication and division" >::
ae (Some ) (evaluate ["2 4 * 3 /"]);
]

let dup_tests = [
"copies a value on the stack" >::
ae (Some [1; 1]) (evaluate ["1 dup"]);
"copies the top value on the stack" >::
ae (Some [1; 2; 2]) (evaluate ["1 2 dup"]);
"errors if there is nothing on the stack" >::
ae None (evaluate ["dup"]);
]

let drop_tests = [
"removes the top value on the stack if it is the only one" >::
ae (Some []) (evaluate ["1 drop"]);
"removes the top value on the stack if it is not the only one" >::
ae (Some ) (evaluate ["1 2 drop"]);
"errors if there is nothing on the stack" >::
ae None (evaluate ["drop"]);
]

let swap_tests = [
"swaps the top two values on the stack if they are the only ones" >::
ae (Some [2; 1]) (evaluate ["1 2 swap"]);
"swaps the top two values on the stack if they are not the only ones" >::
ae (Some [1; 3; 2]) (evaluate ["1 2 3 swap"]);
"errors if there is nothing on the stack" >::
ae None (evaluate ["swap"]);
"errors if there is only one value on the stack" >::
ae None (evaluate ["1 swap"]);
]

let over_tests = [
"copies the second element if there are only two" >::
ae (Some [1; 2; 1]) (evaluate ["1 2 over"]);
"copies the second element if there are more than two" >::
ae (Some [1; 2; 3; 2]) (evaluate ["1 2 3 over"]);
"errors if there is nothing on the stack" >::
ae None (evaluate ["over"]);
"errors if there is only one value on the stack" >::
ae None (evaluate ["1 over"]);
]

let user_defined_words_tests = [
"can consist of built-in words" >::
ae (Some [1; 1; 1]) (evaluate [": dup-twice dup dup ;"; "1 dup-twice"]);
"execute in the right order" >::
ae (Some [1; 2; 3]) (evaluate [": countup 1 2 3 ;"; "countup"]);
"can override other user-defined words" >::
ae (Some [1; 1; 1]) (evaluate [": foo dup ;"; ": foo dup dup ;"; "1 foo"]);
"can override built-in words" >::
ae (Some [1; 1]) (evaluate [": swap dup ;"; "1 swap"]);
"can override built-in operators" >::
ae (Some ) (evaluate [": + * ;"; "3 4 +"]);
"can use different words with the same name" >::
ae (Some [5; 6]) (evaluate [": foo 5 ;"; ": bar foo ;"; ": foo 6 ;"; "bar foo"]);
"can define word that uses word with the same name" >::
ae (Some ) (evaluate [": foo 10 ;"; ": foo foo 1 + ;"; "foo"]);
"cannot redefine numbers" >::
ae None (evaluate [": 1 2 ;"]);
"errors if executing a non-existent word" >::
ae None (evaluate ["foo"]);
]

let case_insensitivity = [
"DUP is case-insensitive" >::
ae (Some [1; 1; 1; 1]) (evaluate ["1 DUP Dup dup"]);
"DROP is case-insensitive" >::
ae (Some ) (evaluate ["1 2 3 4 DROP Drop drop"]);
"SWAP is case-insensitive" >::
ae (Some [2; 3; 4; 1]) (evaluate ["1 2 SWAP 3 Swap 4 swap"]);
"OVER is case-insensitive" >::
ae (Some [1; 2; 1; 2; 1]) (evaluate ["1 2 OVER Over over"]);
"user-defined words are case-insensitive" >::
ae (Some [1; 1; 1; 1]) (evaluate [": foo dup ;"; "1 FOO Foo foo"]);
"definitions are case-insensitive" >::
ae (Some [1; 1; 1; 1]) (evaluate [": SWAP DUP Dup dup ;"; "1 swap"]);
]

let () =
run_test_tt_main (
"forth tests" >:::
List.concat [
parsing_and_numbers_tests;
subtraction_tests;
multiplication_tests;
division_tests;
combined_arithmetic_tests;
dup_tests;
drop_tests;
swap_tests;
over_tests;
user_defined_words_tests;
case_insensitivity;
]
)``````
``````open Base

type stack = int list
type command = (stack -> (stack, string) Result.t)

type token =
| Value of int
| Operator of (string * (int -> int -> int))
| BuiltIn of (string * command)
| Command of string

let oe = Error "Operation failed"
let se = Error "Not enough values on stack"

let is_digits = String.for_all ~f:(Char.is_digit)

let parse (word: string) =
match String.lowercase word with
| "+" -> Operator ("+", (+))
| "-" -> Operator ("-", (-))
| "*" -> Operator ("*", ( * ))
| "/" -> Operator ("/", (/))
| "dup" -> BuiltIn ("dup", function
| h::t -> Ok (h :: h :: t)
| _ -> se)
| "drop" -> BuiltIn ("drop", function
| _::t -> Ok t
| _ -> se)
| "swap" -> BuiltIn ("swap", function
| ha::hb::t -> Ok (hb :: ha :: t)
| _ -> se)
| "over" -> BuiltIn ("over", function
| ha::hb::t -> Ok (hb :: ha :: hb :: t)
| _ -> se)
| n when is_digits n -> Value (Int.of_string n)
| _ -> Command word

let parse_line (line: string): token list =
line |> String.split_on_chars ~on:[' '] |> List.map ~f:parse

let parse_def (def: string): ((string * token list), string) Result.t =
def
|> String.strip ~drop:(fun c -> Char.(c = ':') || Char.(c = ';'))
|> String.split_on_chars ~on:[' ']
|> List.filter ~f:(String.for_all ~f:(Char.is_whitespace) |> Fn.non)
|> function
| h::_ when is_digits h -> Error "Invalid definition"
| h::t -> Ok (h, t |> List.map ~f:parse)
| _ -> Error "Invalid definition"

let evaluate_line (stack: stack) (t: token): (stack, string) Result.t =
match (t, stack) with
| (Value v, _) -> v :: stack |> Result.return
| (Operator (_, op), b::a::t) -> (try Ok ((op a b) :: t) with _ -> oe)
| (BuiltIn (_, cmd), _) -> cmd stack
| (Operator _, []) | (Operator _, [_]) -> se
| (Command _, _) -> Error "Encountered unknown user command"

let is_definition (line: string): bool = Char.(String.get line 0 = ':')

let substitute (defs: (string * token list) list) (token: token): token list =
let get cmd = defs
|> List.find ~f:(fun (name, _) -> String.(cmd = name))
|> Option.value_map ~default:[token] ~f:snd in
match token with
| Operator (sign, _) -> get sign
| Command cmd -> get cmd
| BuiltIn (name, _) -> get name
| _ -> [token]

let evaluate (code: string list): stack option =
let (defs, statements) = List.partition_tf code ~f:is_definition in
List.map defs ~f:parse_def
|> List.rev
|> Result.all
|> Result.bind ~f:(fun defs' -> (
statements
|> List.concat_map ~f:parse_line
|> List.concat_map ~f:(substitute defs')
|> List.fold_result ~init:[] ~f:evaluate_line
|> Result.map ~f:List.rev
))
|> Result.ok``````