Super Stack!/superstack.ml

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

Features

Semantics

• The stack is implemented as a two-way linked list, a deque, which allow cycle, rcycle and rev to all run in constant time.
• Syntax of the interpreted Super Stack! program is completely case-insensitive. Additionally, whitespace are discarded when parsing: "if pop fi" and "ifpOpfi" are equivalent, but "i fpop fi" is a syntax error. Whitespace should be included, though, to remove ambiguity; for instance, orcycle will not be interpreted as or cycle, but as rcycle preceded by an invalid keyword, and thus will result in a syntax error.
• Minor bug: the instruction 'c' described below will treat c as lowercase: for instance 'A' will push the value 97, not 65, to the stack.
• Comments can be inserted using the surround notation comment ... decomment. They are simply discarded when parsing.
  • Properly nested comments are supported
  • Everything that follows an unmatched occurrence of comment up to the end of the program, or everything that precedes an unmatched occurrence of decomment 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:

Instruction	Description
output	Pop the top value and output it as a decimal number (not followed by a space)
inputascii	Get one character from input and push its ascii value on the stack, or 0 on end of file.
rev	Reverse the whole stack, but runs in constant time.
'c'	Push the ascii value of character c; for instance 'd' is equivalent to 100.
equal	Pop y, pop x, push (if x = y then 1 else 0)
less	Pop y, pop x, push (if x < y then 1 else 0).
greater	Pop y, pop x, push (if x > y then 1 else 0).
than	No-op, discarded when parsing.
xnor	Logical xnor: pop y, pop x, push (x xnor y). Equivalent to "not swap not equal".
nor	Logical nor: pop y, pop x, push (x nor y). Equivalent to "0 equal swap 0 equal and".
ternary	Pop b, pop y, pop x, push (if b = 0 then y else x).
clear	If top element is 0, then clear the stack. Runs in constant time, but gives work to the garbage collector.

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...

Source

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))));;

See also

• Super Stack!
• User:Orange/Super_Stack!/v2, an implementation in python by the language author