Carriage/carriage.ml

:< Back to Carriage
A Carriage interpreter in Ocaml, written by User:Koen in mid-november 2012.
* The Carriage program should be passed as a command line argument.
* Explosion during runtime will raise a BOOM exception.
* Explosion because of an invalid character will raise a Syntax_EXPLOSION exception.
* When execution halts without an explosion, the resulting stack is outputted, top-to-bottom. Note that there will be no distinction between the instruction 1 and the number 1.
===Example session===
 $ ocamlc -o carriage carriage.ml
 $ ./carriage '111-~+'
 2 + ~ - 1 1 1 
 $ ./carriage '$$$'
 
 $ ./carriage '11+$11+111+@!'
 3 ! @ + 1 1 1 + 1 1 $ + 1 1 
 $ ./carriage '1+'
 Fatal error: exception Carriage.BOOM
 $ ./carriage 'Hello, World!'
 Fatal error: exception Carriage.Syntax_EXPLOSION</code>
==Source==
type instr = One | Pick | Swap | Pop | Size | Add | Sub | Slice | Apply
type el = Instr of instr | Number of int | Funct of instr list
exception BOOM
let rec pick n s =
 match (n, s) with
 | (0, Instr _ :: _) -> raise BOOM
 | (0, h :: _) -> h
 | (_, h :: t) -> pick (pred n) t
 | _ -> failwith "pick should have exploded already"
let slice k p s =
 let rec sl2 acc k s =
 match (k, s) with
 | (0, _) -> acc
 | (k, Instr h :: t) -> sl2 (h :: acc) (pred k) t
 | (_, _ :: _) -> raise BOOM
 | _ -> raise BOOM
 in
 let rec sl1 p k s =
 match (p, s) with
 | (0, s) -> sl2 [] k s
 | (p, h :: t) -> sl1 (pred p) k t
 | _ -> failwith "sl1"
 in
 (sl1 p k s)
 let print_instr i = match i with
 | One -> print_string "1"
 | Pick -> print_char '~'
 | Swap -> print_char '\\'
 | Pop -> print_char '$'
 | Size -> print_char '#'
 | Add -> print_char '+'
 | Sub -> print_char '-'
 | Slice -> print_char '@'
 | Apply -> print_char '!'
let rec print_stack s =
 match s with
 | Number n :: t -> print_int n; print_char ' '; print_stack t
 | Instr i :: t -> print_instr i; print_char ' '; print_stack t
 | Funct f :: t ->
 List.iter (print_instr) f; print_char ' '; print_stack t
 | _ -> ();
 print_newline ()
let rec apply f (s, length) =
 List.fold_left (execute) (s, length) (f)
and execute (s, length) i =
 match (i, s) with
 | (One, _) -> (Number 1 :: s, succ length)
 | (Pick, Number n :: t) when n < length && n >= 0 ->
 (pick n t :: t, length)
 | (Swap, a :: b :: t) -> (b :: a :: t, length)
 | (Pop, _ :: t) -> (t, pred length)
 | (Size, _) -> (Number length :: s, succ length)
 | (Add, Number a :: Number b :: t) -> (Number (a + b) :: t, pred length)
 | (Sub, Number a :: Number b :: t) -> (Number (b - a) :: t, pred length)
 | (Slice, Number k :: Number p :: t) when
 p >= 0 && k >= 0 && p + k - 1 < length ->
 let x = slice k (length - p - 4) t
 in
 (Funct x :: t, pred length)
 | (Apply, Funct f :: t) -> apply f (t, length)
 | _ -> raise BOOM
exception Syntax_EXPLOSION;;
let p = Sys.argv.(1) and s = ref [];;
for k = String.length p - 1 downto 0 do
 match p.[k] with
 | '1' -> s := One :: !s
 | '~' -> s := Pick :: !s
 | '\\' -> s := Swap :: !s
 | '$' -> s := Pop :: !s
 | '#' -> s := Size :: !s
 | '+' -> s := Add :: !s
 | '-' -> s := Sub :: !s
 | '@' -> s := Slice :: !s
 | '!' -> s := Apply :: !s
 | ' ' | '\n' | '\t' -> ()
 | _ -> raise Syntax_EXPLOSION
done;;
let data =
 List.fold_left
 (fun (acc, n) i -> (Instr i :: acc, succ n))
 ([], 0)
 !s
in
print_stack (fst (apply !s data));;
==See also==
* Carriage
* Carriage/Carriage.hs
Category:Implementations