Avatar of marionebl

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. Install the Exercism CLI.

  2. Install OCaml.

  3. 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"]);
]


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 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 [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 +"]);
  "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 [11]) (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 [1]) (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; 
      addition_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

Community comments

Find this solution interesting? Ask the author a question to learn more.

What can you learn from this solution?

A huge amount can be learned from reading other people’s code. This is why we wanted to give exercism users the option of making their solutions public.

Here are some questions to help you reflect on this solution and learn the most from it.

  • What compromises have been made?
  • Are there new concepts here that you could read more about to improve your understanding?