Super Stack!/superstack.ml

A Super Stack! interpreter in Ocaml, written by User:Koen in 2012.

Semantics

 * The stack is implemented as a two-way linked list, a deque, which allow,   and   to all run in constant time.
 * Syntax of the interpreted Super Stack! program is completely case-insensitive. Additionally, whitespace are discarded when parsing: " " and " " are equivalent, but " " is a syntax error. Whitespace should be included, though, to remove ambiguity; for instance,  will not be interpreted as , but as   preceded by an invalid keyword, and thus will result in a syntax error.
 * Minor bug: the instruction  described below will treat c as lowercase: for instance   will push the value 97, not 65, to the stack.
 * Comments can be inserted using the surround notation  ...  . They are simply discarded when parsing.
 * Properly nested comments are supported
 * Everything that follows an unmatched occurrence of  up to the end of the program, or everything that precedes an unmatched occurrence of   down from the beginning of the program, will be ignored
 * Everything that is not part of a comment, a valid instruction, or whitespace is a syntax error.
 * Some new instructions have been added, and some instructions might differ from the specifications:

Use
ocamlc deque.mli ocamlc -c deque.ml ocamlc deque.cmo -o superstack superstack.ml ./superstack '0 10 33 100 108 114 111 87 32 44 111 108 108 101 72 if outputascii fi' :Hello, World! echo 'A cat program...' | ./superstack 'inputascii if outputascii inputascii fi' :A cat program...

deque.mli
type 'a t exception Empty val create : unit -> 'a t val clear : 'a t -> unit val push_back : 'a -> 'a t -> unit val pop_back : 'a t -> 'a val peek_back : 'a t -> 'a val push_front : 'a -> 'a t -> unit val pop_front : 'a t -> 'a val peek_front : 'a t -> 'a val next : 'a t -> unit val prev : 'a t -> unit val copy : 'a t -> 'a t val is_empty : 'a t -> bool val length : 'a t -> int

deque.ml
exception Empty

type 'a cell = { content: 'a; mutable next: 'a cell; mutable prev: 'a cell }

type 'a t = { mutable length: int; mutable front: 'a cell }

let create = { length = 0; front = Obj.magic None }

let clear q = q.length <- 0; q.front <- Obj.magic None

let push_back x q = if q.length = 0 then let rec cell = { content = x;     next = cell; prev = cell } in   q.length <- 1; q.front <- cell else let cell = { content = x;     next = q.front; prev = q.front.prev } in   q.length <- succ q.length; q.front.prev.next <- cell; q.front.prev <- cell

let next q = if q.length > 0 then q.front <- q.front.next

let prev q = if q.length > 0 then q.front <- q.front.prev

let push_front x q = push_back x q; prev q

let peek_front q = if q.length = 0 then raise Empty else q.front.content

let peek_back q = if q.length = 0 then raise Empty else q.front.prev.content

let pop_back q = if q.length = 0 then raise Empty; q.length <- q.length - 1; let x = q.front.prev.content in if q.length = 0 then q.front <- Obj.magic None else (   q.front.prev.prev.next <- q.front;    q.front.prev <- q.front.prev.prev    ); x

let pop_front q = next q; pop_back q

let copy q = if q.length = 0 then create else begin let c = ref q.front in   let rec d = { content = q.front.content; next = d;     prev = d    } in    let d = ref d in    for k = 2 to q.length do      c := !c.next; d := { content = !c.content; next = !d.next; prev = !d };     !d.prev.next <- !d; done; !d.next.prev <- !d; {     front = !d.next; length = q.length } end

let is_empty q = q.length = 0

let length q = q.length

superstack.ml
type instruction = N of int | Add | Sub | Mul | Div | Mod | Random | Equal | Less_than | Greater_than | And | Or | Xor | Xnor | Nor | Nand | Not | Output | Input | Out | In | Pop | Swap | Cycle | Rcycle | Dup | Rev | If | Fi | Quit | Debug | Ternary | Clear

exception Syntax_error of string

let remove_com text = let rec rc n text = match text with | 't'::'n'::'e'::'m'::'m'::'o'::'c'::'e'::'d' :: t -> rc (succ n) t   | 't'::'n'::'e'::'m'::'m'::'o'::'c' :: t -> if n = 0 then t else rc (pred n) t   | _ :: t -> rc n t    | [] -> [] in rc 0 text

let rec parser acc text = match text with | ' ' :: t | '\n' :: t | '\t' :: t -> parser acc t | 'd'::'d'::'a' :: t -> parser (Add :: acc) t  | 'b'::'u'::'s' :: t -> parser (Sub :: acc) t  | 'l'::'u'::'m' :: t -> parser (Mul :: acc) t  | 'v'::'i'::'d' :: t -> parser (Div :: acc) t  | 'd'::'o'::'m' :: t -> parser (Mod :: acc) t  | 'm'::'o'::'d'::'n'::'a'::'r' :: t -> parser (Random :: acc) t  | 'l'::'a'::'u'::'q'::'e' :: t -> parser (Equal :: acc) t  | 's'::'s'::'e'::'l' :: t -> parser (Less_than :: acc) t  | 'r'::'e'::'t'::'a'::'e'::'r'::'g' :: t -> parser (Greater_than :: acc) t | 'n'::'a'::'h'::'t' :: t -> parser acc t  | 'r'::'o'::'x' :: t -> parser (Xor :: acc) t  | 'r'::'o'::'n'::'x' :: t -> parser (Xnor :: acc) t  | 'r'::'o'::'n' :: t -> parser (Nor :: acc) t  | 'r'::'o' :: t -> parser (Or :: acc) t  | 'd'::'n'::'a'::'n' :: t -> parser (Nand :: acc) t  | 'd'::'n'::'a' :: t -> parser (And :: acc) t  | 't'::'o'::'n' :: t -> parser (Not :: acc) t  | 't'::'u'::'p'::'t'::'u'::'o' :: t -> parser (Output :: acc) t  | 't'::'u'::'p'::'n'::'i' :: t -> parser (Input :: acc) t  | 'i'::'i'::'c'::'s'::'a'::'t'::'u'::'p'::'t'::'u'::'o' :: t -> parser (Out :: acc) t | 'i'::'i'::'c'::'s'::'a'::'t'::'u'::'p'::'n'::'i' :: t -> parser (In :: acc) t | 'p'::'o'::'p' :: t -> parser (Pop :: acc) t  | 'p'::'a'::'w'::'s' :: t -> parser (Swap :: acc) t  | 'e'::'l'::'c'::'y'::'c'::'r' :: t -> parser (Rcycle :: acc) t  | 'e'::'l'::'c'::'y'::'c' :: t -> parser (Cycle :: acc) t  | 'p'::'u'::'d' :: t -> parser (Dup :: acc) t  | 'v'::'e'::'r' :: t -> parser (Rev :: acc) t  | 'f'::'i' :: t -> parser (If :: acc) t  | 'i'::'f' :: t -> parser (Fi :: acc) t  | 't'::'i'::'u'::'q' :: t -> parser (Quit :: acc) t  | 'g'::'u'::'b'::'e'::'d' :: t -> parser (Debug :: acc) t  | 'y'::'r'::'a'::'n'::'r'::'e'::'t' :: t -> parser (Ternary :: acc) t  | 'r'::'a'::'e'::'l'::'c' :: t -> parser (Clear :: acc) t  | 't'::'n'::'e'::'m'::'m'::'o'::'c'::'e'::'d' :: t -> parser acc (remove_com t) | 't'::'n'::'e'::'m'::'m'::'o'::'c' :: t -> parser [] t  | '0' :: t | '1' :: t | '2' :: t | '3' :: t | '4' :: t  | '5' :: t | '6' :: t | '7' :: t | '8' :: t | '9' :: t -> parse_n (N 1 :: N 0 :: acc) text | '\ :: x :: '\ :: t -> parser (N (Char.code x) :: acc) t | h :: t -> raise (Syntax_error (let x = "Unexpected character " in x.[21] <- h; x)) | [] -> acc and parse_n acc text = match (acc, text) with | (N d :: N x :: acc, h :: t) -> let k = Char.code h - Char.code '0' in   if k < 10 && k >= 0 then parse_n (N (d * 10) :: N (x + d * k) :: acc) t     else parser (N x :: acc) text | (N d :: N x :: acc, []) -> N x :: acc | _ -> failwith "parse_n"

let list_of_string s = let l = ref [] in for k = 0 to String.length s - 1 do    l := s.[k] :: !l done; !l

let s = Deque.create

let toggle = ref true;; Random.self_init ;;

let push x s = if !toggle then Deque.push_back x s else Deque.push_front x s let pop s = if !toggle then Deque.pop_back s else Deque.pop_front s let peek s = if !toggle then Deque.peek_back s else Deque.peek_front s let cycle s = if !toggle then Deque.prev s else Deque.next s let rcycle s = if !toggle then Deque.next s else Deque.prev s

let input_ = try int_of_char (input_char stdin) with | End_of_file -> 0

let go_to left right = let rec go_to n left right = match right with | If :: t -> go_to (succ n) (If :: left) t   | Fi :: t -> if n = 0 then (Fi :: left, t)     else go_to (pred n) (Fi :: left) t    | h :: t -> go_to n (h :: left) t    | [] -> raise (Syntax_error "Expecting 'fi'; 'if' might be unmatched.") in go_to 0 left right

let go_back_to left right = let rec gbt n l r = match l with | Fi :: t -> gbt (succ n) t (Fi :: r)   | If :: t -> if n = 0 then (l, r) else gbt (pred n) t (If :: r)   | h :: t -> gbt n t (h :: r)    | [] -> raise (Syntax_error "Expecting 'if'; 'fi' might be unmatched.") in gbt 0 left right

let execute = function | N n -> push n s | Add -> let y = pop s in   let x = pop s in    push (x + y) s  | Sub -> let y = pop s in   let x = pop s in    push (x - y) s  | Mul -> let y = pop s in   let x = pop s in    push (x * y) s  | Div -> let y = pop s in   let x = pop s in    push (x / y) s  | Mod -> let y = pop s in   let x = pop s in    push (x mod y) s  | Random -> push (Random.int (pop s)) s  | Equal -> let y = pop s in   let x = pop s in    push (if x = y then 1 else 0) s  | Less_than -> let y = pop s in   let x = pop s in    push (if x < y then 1 else 0) s  | Greater_than -> let y = pop s in   let x = pop s in    push (if x > y then 1 else 0) s  | And -> let y = pop s in   let x = pop s in    push (if x = 0 || y = 0 then 0 else 1) s  | Or -> let y = pop s in   let x = pop s in    push (if x = 0 && y = 0 then 0 else 1) s  | Xor -> let y = pop s in   let x = pop s in    push (if x = 0 && y <> 0 || y = 0 && x <> 0 then 1 else 0) s  | Xnor -> let y = pop s in   let x = pop s in    push (if x = 0 && y <> 0 || y = 0 && x <> 0 then 0 else 1) s  | Nor -> let y = pop s in   let x = pop s in    push (if x = 0 && y = 0 then 1 else 0) s  | Nand -> let y = pop s in   let x = pop s in    push (if x = 0 || y = 0 then 1 else 0) s  | Not -> push (if (pop s = 0) then 1 else 0) s  | Output -> print_int (pop s)  | Input -> push (read_int ) s  | Out -> print_char (Char.chr (pop s)) | In -> push (input_ ) s | Pop -> ignore (pop s)  | Swap -> let y = pop s in   let x = pop s in    (push y s; push x s)  | Cycle -> cycle s  | Rcycle -> rcycle s  | Dup -> push (peek s) s  | Rev -> toggle := not !toggle | If | Fi | Quit -> failwith "flow control" | Debug -> for k = 1 to Deque.length s do     print_int (peek s); print_char ' '; cycle s done; print_newline | Ternary -> let b = pop s in   let y = pop s in    let x = pop s in    push (if b = 0 then y else x) s  | Clear -> if peek s = 0 then Deque.clear s

let rec process left right = match right with | If :: t -> let (l, r) = if peek s = 0 then go_to (If :: left) t else (If :: left, t)   in    process l r  | Fi :: t -> let (l, r) = if peek s = 0 then (Fi :: left, t) else go_back_to left right in   process l r  | Quit :: t -> | x :: t -> execute x; process (x :: left) t | [] -> ;;

process [] (parser [] (list_of_string (String.lowercase Sys.argv.(1))));;