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.
For installation and learning resources, refer to the exercism help page.
To work on the exercises, you will need Opam
and Base
. Consult opam website for instructions on how to install opam
for your OS. Once opam
is installed open a terminal window and run the following command to install base:
opam install base
To run the tests you will need OUnit
. Install it using opam
:
opam install ounit
A Makefile is provided with a default target to compile your solution and run the tests. At the command line, type:
make
utop
is a command line program which allows you to run Ocaml code interactively. The easiest way to install it is via opam:
opam install utop
Consult utop for more detail.
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. We'll do our best to help you!
It's possible to submit an incomplete solution so you can see how others have completed the exercise.
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"]);
]
let addition_tests = [
"can add two numbers" >::
ae (Some [3]) (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 [8]) (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 [4]) (evaluate ["12 3 /"]);
"performs integer division" >::
ae (Some [2]) (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 = [
"addition and subtraction" >::
ae (Some [-1]) (evaluate ["1 2 + 4 -"]);
"multiplication and division" >::
ae (Some [2]) (evaluate ["2 4 * 3 /"]);
]
let dup_tests = [
"copies the top value on the stack" >::
ae (Some [1; 1]) (evaluate ["1 DUP"]);
"is case-insensitive" >::
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 [1]) (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 [12]) (evaluate [": + * ;"; "3 4 +"]);
"cannot redefine numbers" >::
ae None (evaluate [": 1 2 ;"]);
"errors if executing a non-existent word" >::
ae None (evaluate ["foo"]);
]
let () =
run_test_tt_main (
"forth tests" >:::
List.concat [
parsing_and_numbers_tests;
addition_tests;
subtraction_tests;
multiplication_tests;
division_tests;
combined_arithmetic_tests;
dup_tests;
drop_tests;
swap_tests;
over_tests;
user_defined_words_tests
]
)
open Containers
module SMap = Map.Make(String)
type mathop = Add | Sub | Mul | Div
type stackop = Dup | Drop | Over | Swap
type primitive =
| Mathop of mathop
| Stackop of stackop
type token =
| Semicolon
| Colon
| Word of string
| Number of int
type atomic_word =
| AWord of string
| ANumber of int
type word =
| Primitive of primitive
| User of atomic_word list
exception Fail_early
let fail_early () = raise Fail_early
let unwrap_result = function
| Ok x -> x
| Error _ -> fail_early ()
let unwrap_opt = function
| Some x -> x
| None -> fail_early ()
let return_if b x =
if b then
x
else
fail_early ()
let lexer line =
let word_re = Re.(rep1 (inter [ascii; print])) in
let token_re =
let open Tyre in
let route_arg = [
char ':' --> (fun () -> Colon);
char ';' --> (fun () -> Semicolon);
pos_int --> (fun i -> Number i);
regex word_re --> (fun w -> Word (String.lowercase_ascii w));
]
in
route (List.map (fun (Route (re, f)) -> Route (whole_string re, f)) route_arg)
in
let ws = Re.(compile (rep1 blank)) in
let potential_tokens = Re.(split ws line) in
List.map (fun t -> unwrap_result (Tyre.exec token_re t)) potential_tokens
let compute_mathop mathop x y =
match mathop with
| Add -> x + y
| Sub -> x - y
| Mul -> x * y
| Div ->
if y = 0 then
fail_early ()
else
x / y
let get_two stack =
match stack with
| newer :: older :: stack -> (stack, older, newer)
| _ -> fail_early ()
let apply_stackop stackop stack =
match stackop with
| Dup ->
unwrap_opt (List.head_opt stack) :: stack
| Drop ->
unwrap_opt (List.tail_opt stack)
| Over ->
let _, x, _ = get_two stack in
x :: stack
| Swap ->
let stack, x, y = get_two stack in
x :: y :: stack
let apply_primitive prim stack =
match prim with
| Mathop mathop ->
let stack, x, y = get_two stack in
compute_mathop mathop x y :: stack
| Stackop stackop ->
apply_stackop stackop stack
let rec interpret_word dict stack word =
match word with
| ANumber i -> i :: stack
| AWord w ->
begin match SMap.find w dict with
| Primitive prim -> apply_primitive prim stack
| User ws -> interpret_words dict stack ws
end
and interpret_words dict stack words =
match words with
| [] -> stack
| w :: ws ->
let stack = interpret_word dict stack w in
interpret_words dict stack ws
let validate ~terminated dict line =
let rec loop acc tail =
match tail with
| [] -> return_if (not terminated) acc
| [Semicolon] -> return_if terminated acc
| Semicolon :: _ :: _ | Colon :: _-> fail_early ()
| Number i :: rest -> loop (ANumber i :: acc) rest
| Word w :: rest ->
if SMap.mem w dict then
loop (AWord w :: acc) rest
else
fail_early ()
in
List.rev (loop [] line)
let interpret_line dict stack line =
match line with
| [] -> (dict, stack)
| Colon :: Word w :: rest ->
let ws = validate ~terminated:true dict rest in
(SMap.add w (User ws) dict, stack)
| _ ->
let words = validate ~terminated:false dict line in
let stack = interpret_words dict stack words in
(dict, stack)
let initial_dict =
let primitives = [
("+", Mathop Add);
("-", Mathop Sub);
("*", Mathop Mul);
("/", Mathop Div);
("dup", Stackop Dup);
("over", Stackop Over);
("swap", Stackop Swap);
("drop", Stackop Drop);
] in
primitives
|> List.to_seq
|> Iter.map (fun (name, def) -> (name, Primitive def))
|> SMap.of_seq
let evaluate statements =
try
let tokens = List.map lexer statements in
let _, stack =
List.fold_left (fun (dict, stack) line -> interpret_line dict stack line)
(initial_dict, []) tokens
in
Some (List.rev stack)
with Fail_early -> None
The first version uses some monad-fu, the second one uses exceptions. I have no strong opinions here. The second one is not clearly simpler (it's exactly the same structure) but it's easier to read and write I think (no fancy combinators all over the place). It's probably faster too. Afaict adding error reporting would be fairly similar in both cases.
Level up your programming skills with 3,091 exercises across 52 languages, and insightful discussion with our volunteer team of welcoming mentors. Exercism is 100% free forever.
Sign up Learn More
Community comments