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===
<nowiki>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</nowiki>
===superstack.ml===
<nowiki>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))));;</nowiki>
==See also==
* Super Stack!
* User:Orange/Super_Stack!/v2, an implementation in python by the language author
Category:Implementations