type token = T_w | T_W | T_v | EOF;;
let rec scan s i = (
let length = String.length s in
if i >= length then length, EOF else
match s.[i] with
| 'W' -> i + 1, T_W
| 'w' -> i + 1, T_w
| 'v' -> i + 1, T_v
| '\xef' -> (* Ｗ : EF BC B7, ｖ : EF BD 96, ｗ : EF BD 97 *)
if i + 2 >= length then length, EOF else
begin match s.[i + 1] with
| '\xbc' ->
begin match s.[i + 2] with
| '\xb7' -> i + 3, T_W
| _ -> scan s (i + 3)
end
| '\xbd' ->
begin match s.[i + 2] with
| '\x96' -> i + 3, T_v
| '\x97' -> i + 3, T_w
| _ -> scan s (i + 3)
end
| _ -> scan s (i + 3)
end
| _ -> scan s (i + 1)
);;
type value = Value of char option * (value -> value);;
let interpret stack source = (
let rec interpret stack source ((index, token) as position) = (
let rec apply stack f a = (
match stack with
| s :: sr ->
if a = 1 then (
let Value (_, func) = List.nth stack (f - 1) in
func s
) else if f = 1 then (
let Value (_, func) = s in
let arg = List.nth stack (a - 1) in
func arg
) else (
apply sr (f - 1) (a - 1)
)
| [] -> raise (Failure "Stack underflow!\n")
) in
let rec read target source ((index, token) as position) n = (
if token = target then (
read target source (scan source index) (n + 1)
) else (
position, n
)
) in
let rec read_body source position body = (
let position, f = read T_W source position 0 in
if f = 0 then (position, List.rev body) else
let position, a = read T_w source position 0 in
read_body source position ((f, a) :: body)
) in
match token with
| EOF ->
(* 最後に来たらApply(1,1)して終了 *)
let _ = apply stack 1 1 in ()
| T_w ->
(* 関数定義 *)
let position, argc = read T_w source position 0 in
let position, body = read_body source position [] in
let rec bind n stack arg = (
let stack = arg :: stack in
if n = 1 then (
let rec loop stack body = (
match body with
| [] -> List.hd stack
| (f, a) :: [] -> apply stack f a
| (f, a) :: br -> loop ((apply stack f a) :: stack) br
) in loop stack body
) else (
Value (None, bind (n - 1) stack)
)
) in
let r = Value (None, bind argc stack) in
interpret (r :: stack) source position
| T_W ->
(* 関数適用 *)
let position, f = read T_W source position 0 in
let position, a = read T_w source position 0 in
let r = apply stack f a in
interpret (r :: stack) source position
| T_v -> interpret stack source (scan source index) (* skip *)
) in
let find_first s = (
let rec loop s i = (
let (j, t) as r = scan s i in
match t with
| T_w | EOF -> r
| _ -> loop s j
) in
loop s 0
) in
interpret stack source (find_first source)
);;
let true_f = Value (None, fun x -> Value (None, fun _ -> x));;
let false_f = Value (None, fun _ -> Value (None, fun y -> y));;
let char_f x = Value (Some x, fun y ->
match y with
| Value (Some y, _) -> if x = y then true_f else false_f
| _ -> raise (Failure "In equal, argument is not char!\n"));;
let init_stack = [
Value (None, function
| Value (Some c, _) as a -> print_char c; if c = '\n' then flush stdout; a
| _ -> raise (Failure "In primitive out, argument is not char!\n"));
Value (None, function
| Value (Some c, _) -> char_f (char_of_int ((int_of_char c + 1) mod 256))
| _ -> raise (Failure "In primitive succ, argument is not char!\n"));
char_f 'w';
Value (None, fun x -> try char_f (input_char stdin) with End_of_file -> x)];;
let read_all filename = (
let f = open_in_bin filename in
let size = in_channel_length f in
let result = String.make size '\x00' in
really_input f result 0 size;
close_in f;
result
);;
let filename = Sys.argv.(1) in
interpret init_stack (read_all filename);;