ocaml implementation of http://www.blue.sky.or.jp/grass/

grass.ml

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

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 = really_input_string f size in
	close_in f;
	result
);;

let filename = Sys.argv.(1) in
interpret init_stack (read_all filename);;