Avatar of itshugo

itshugo's solution

to Forth in the OCaml Track

Published at Sep 01 2018 · 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

For installation and learning resources, refer to the exercism help page.

Installation

To work on the exercises, you will need Opam and Core. 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 core:

opam install core

To run the tests you will need OUnit. Install it using opam:

opam install ounit

Running Tests

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

make

Interactive Shell

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.

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. We'll do our best to help you!

Submitting Incomplete Solutions

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

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 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
        ]
  )
(* Defines a simple interpreter for a Forth-like stack-based programming 
 * language.
 *)

open Base

(* remove first 2 values off a list and apply a function *)
let pop2 f = function 
    | a :: b :: l -> f a b l
    | _ -> None

(* apply a function on the top 2 values of a list and add to the
 * front of the list *)
let pop2a f = pop2 (fun a b l -> Some ((f a b) :: l))

(* apply a function to the contents of an option, if any; function must
 * replace option constructor *)
let option_apply f = function
    | Some x -> f x
    | _ -> None

(* apply a function to the contents of an option, if any *)
let option_map f = option_apply (fun x -> Some (f x))

(* reverse order of first two arguments of a function *)
let flip f = fun x y -> f y x

(* function composition *) 
let (|>) f g = fun x -> f(g(x))

(* delayed function application *)
let (@>) f x = f x

let is_none = function
    | None -> true
    | _ -> false

let int_of_string s = try Some (Int.of_string s) with Failure _ -> None

(* eval_token returns an updated stack given a Map of word bindings, a token 
 * (either a word, symbol, or number), and a stack
 * 
 * Supports the following words:
 *   +, -, *, / (integer arithmetic)
 *   DUP, DROP, SWAP, OVER (stack manipulation)
 * 
 * Supports defining new words using the customary syntax: 
 *   : word-name definition ;.
 * 
 * The only data type supported is signed integers of at least 16 bits size.
 * 
 * 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.
 *)
let rec eval_token words = option_apply |> (fun top st ->
    try Some ((Int.of_string top) :: st)
    with Failure _ -> match Map.find words top with
      | Some expr -> eval_input words (Some st) expr
      | _ -> (match top with
        (* perform arithmetic on top two values of stack,
         * or raise stack underflow exception *)
        | "+" -> pop2a ( + )
        | "-" -> pop2a (flip ( - ))
        | "*" -> pop2a ( * )
        | "/" -> pop2 (fun a b l -> if Int.equal a 0 
                       then None else Some ((b / a) :: l))
        (* duplicate top value of stack or raise stack underflow *)
        | "dup" -> (fun st -> option_apply (fun top -> Some (top :: st)) (List.hd st))
        (* remove top value of st or raise stack underflow *)
        | "drop" -> List.tl 
        (* swap top two values of stack or raise stack underflow *)
        | "swap" -> pop2 (fun a b l -> Some (b :: a :: l))
        (* duplicate second value of stack or raise stack underflow *)
        | "over" -> pop2 (fun a b l -> Some (b :: a :: b :: l))
        | _ -> (fun _ -> None)
     ) st) |> String.lowercase

(* evaluate a line of input given bindings and initial stack *) 
and eval_input words init_stack input = 
    let tokens = String.split_on_chars input ~on:[' '; '\t'] in
    List.fold tokens ~init:init_stack ~f:(flip (eval_token words))


let evaluate inputs =
    (option_map List.rev) @> fst @> 
      List.fold inputs ~init:(Some [], Map.empty (module String)) 
      ~f:(fun (stack, words) input -> 
         match stack with
         (* short-circuit *)
         | None -> (stack, words)
         | _ ->
          let suffix = " ;" and prefix = ": " in
          let sl = String.length suffix and pl = String.length prefix in
          if String.is_suffix input ~suffix:suffix 
          && String.is_prefix input ~prefix:prefix
          then 
            let meat = String.drop_suffix 
                      (String.drop_prefix input pl) sl in 
            let (word, expr) = String.lsplit2_exn meat ~on:' ' in 
            if String.equal word expr || not (is_none (int_of_string word))
            then (None, words)
            else (stack, Map.add_exn (Map.remove words word) ~key:word ~data:expr)
          else (eval_input words stack input, words) 
      )

Community comments

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

itshugo's Reflection

This was a fun way to learn OCaml after coming in with a background in Haskell. The syntax is unusual, but I don't mind such languages. I also had trouble finding the right functional programming idioms and functions, which is why I defined functions like option_map and flip.