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

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