OCaml で書く Tcl インタプリタ 3

Haskell で 250 行で書かれた Tcl インタプリタ [1] というのがあった（行数の数えかたはあやしいが）ので思い出して自作 OCaml 製 Tcl インタプリタ [2] をまたいじってみた。今回は proc, global, upvar に対応してできることの幅がだいぶ広がった。結果として230行に。

open ExtList
open ExtString
module StringMap = Map.Make(String)
exception Unknown_command of string
exception Wrong_number_of_args

let string_of_char = String.make 1

module TclInterp = struct
  type frame_entry = Value of string | Global | Upvar of (string * int)
  type frame = frame_entry StringMap.t

  type interp = {
    result : string;
    g : string StringMap.t;
    frames : frame list;
    procs : (string * proc) list;
  }
  and proc = interp -> string list -> interp

  let initial_interp = {
    result = "";
    g = StringMap.empty;
    frames = [];
    procs = [];
  }

  let uplevel = List.drop
  let global name interp = StringMap.find name interp.g
  let local name frame = StringMap.find name frame

  let rec var_lookup name interp =
    match interp.frames with
      | [] -> global name interp
      | frame::_ as frames ->
        match (local name frame) with
          | Value v -> v
          | Global -> global name interp
          | Upvar (name, level) ->
            var_lookup name {interp with frames = uplevel level frames}

  let set_global name value interp =
    {interp with g = StringMap.add name value interp.g}
  let set_local name value frame = StringMap.add name (Value value) frame

  let rec var_update name value interp =
    match interp.frames with
      | [] -> set_global name value interp
      | frame::xs as frames ->
        if StringMap.mem name frame then
          match (local name frame) with
            | Value _ ->
              {interp with frames = (set_local name value frame)::xs}
            | Global -> set_global name value interp
            | Upvar (name, level) ->
              let intermediate= List.take level frames in
              let upframe = uplevel level frames in
              let interp' =
                var_update name value {interp with frames = upframe} in
              {interp' with frames = intermediate @ interp'.frames}
        else
          {interp with frames = (set_local name value frame)::xs}
end

module TclParserState = struct
  type state = {
      openBraces : int;
      argv : string list;
      buf : string;
      nest : bool;
  }
  let initial_state = {openBraces = 0; argv = []; buf=""; nest = false;}
  let argv_of_state state =
      let argv =
        if state.buf = "" then state.argv else state.buf::state.argv in
      List.rev argv
  let add_arg state =
      {state with argv = state.buf::state.argv; buf = ""}
  let ($^) state c =
      {state with buf = state.buf ^ string_of_char c}
  let ($^^) state s =
      {state with buf = state.buf ^ s}
  let flush state =
      {state with argv = []; buf = ""}
  let incrbrace state =
      {state with openBraces = state.openBraces + 1}
  let decrbrace state =
      {state with openBraces = state.openBraces - 1}
end

open TclInterp
open TclParserState

let invoke interp = function
  | name::args ->
    if List.mem_assoc name interp.procs then
      let proc = List.assoc name interp.procs in
      proc interp args
    else
      raise (Unknown_command name)
  | _ -> raise (Unknown_command "")

let backslash = parser
  | [< ''\n' >] -> ' '
  | [< ''n'  >] -> '\n'
  | [< ''t'  >] -> '\t'
  | [< 'c    >] -> c
  | [<       >] -> '\\'

let rec varsub interp name = parser
  | [< ''A'..'Z' | 'a'..'z' | '_' | '0'..'9' as c; strm>]
          -> varsub interp (name ^ string_of_char c) strm
  | [< >] -> if name = "" then "$" else var_lookup name interp

let rec eval interp state = parser
  | [< '' '|'\t'|'\r'|'\n'|';'; strm >] -> eval interp state strm
  | [< ''#'; strm >] -> comment interp state strm
  | [< strm >] -> command interp state strm
and comment interp state = parser
  | [< ''\n'; strm >] -> eval interp state strm
  | [< ''\\'; strm >] -> ignore (backslash strm); comment interp state strm
  | [< '_;    strm >] -> comment interp state strm
  | [<        strm >] -> interp
and command interp state = parser
  | [< '']' when state.nest; >] -> invoke interp (argv_of_state state)
  | [< '';'|'\n'; strm >] ->
      eval (invoke interp (argv_of_state state)) (flush state) strm
  | [< ''\\'; strm >] ->
      command interp (state $^ backslash strm) strm
  | [< '' '|'\t'|'\r' when state.buf = ""; strm >] ->
      command interp state strm
  | [< '' '|'\t'|'\r'; strm >] -> command interp (add_arg state) strm
  | [< ''{'  when state.buf = ""; strm >] ->
      brace interp {state with openBraces = 1} strm
  | [< ''\"' when state.buf = ""; strm >] ->
      quote interp state strm
  | [< ''$'; strm >] ->
      command interp (state $^^ varsub interp "" strm) strm
  | [< ''['; strm >] ->
      let interp = cmdsub interp strm state in
      command interp (state $^^ interp.result) strm
  | [< 'c; strm >] -> command interp (state $^ c) strm
  | [< >] ->
      let argv = argv_of_state state in
      if argv = [] then
          interp
      else
          invoke interp argv
and brace interp state = parser
  | [< ''\\' as c; strm >] -> brace interp (state $^ c) strm
  | [< ''{'  as c; strm >] -> brace interp (incrbrace (state $^c)) strm
  | [< ''}'  as c; strm >] ->
      if state.openBraces = 1 then
          command interp (decrbrace (add_arg state)) strm
      else
          brace interp (decrbrace (state $^ c)) strm
  | [< 'c; strm >] -> brace interp (state $^ c) strm
  | [<     strm >] -> command interp state strm
and quote interp state = parser
  | [< ''\\'; strm >] -> quote interp (state $^ backslash strm) strm
  | [< ''\"'; strm >] -> command interp (add_arg state) strm
  | [< ''$';  strm >] -> quote interp (state $^^ varsub interp "" strm) strm
  | [< ''[';  strm >] -> let interp = cmdsub interp strm state in
                         quote interp (state $^^ interp.result) strm
  | [< 'c;    strm >] -> quote interp (state $^ c) strm
  | [<        strm >] -> command interp state strm
and cmdsub interp strm state =
  eval interp {openBraces = 0; argv = []; buf= "" ; nest = true;} strm

(* quick hack !! *)
let parse_as_list = function
  | "" -> []
  | s -> String.nsplit s " "

let register_builtins interp =
  let puts interp = function
    | str::[] -> (Printf.printf "%s\n" str; interp)
    | _ -> raise Wrong_number_of_args
  in
  let set interp = function
    | [name] -> {interp with result = var_lookup name interp}
    | [name; value] -> {var_update name value interp with result = value}
    | _ -> raise Wrong_number_of_args
  in
  let proc interp = function
    | name::formals::body::[] ->
      let formals' = parse_as_list formals in
      let proc = fun interp args ->
       let pairs = List.combine formals' args in
        let locals = List.fold_left (fun e (k, v) -> StringMap.add k (Value v) e) StringMap.empty pairs
        in
        let interp' = eval
          {interp with frames = locals::interp.frames}
          initial_state
          (Stream.of_string body)
        in
        {interp' with frames = uplevel 1 interp'.frames}
      in
      {interp with procs = (name, proc)::interp.procs}
    | _ -> raise Wrong_number_of_args
  in
  let global interp names =
    match interp.frames with
      | [] -> interp
      | frame::xs ->
        let frame' = List.fold_left (fun e k -> StringMap.add k Global e) frame names in
        {interp with frames = frame'::xs}
  in
  let upvar interp = function
    | [] -> raise Wrong_number_of_args
    | level::pairs ->
      let level' = int_of_string level in
      let rec upvar' level frame = function
        | other::my::xs ->
          let frame' = StringMap.add my (Upvar (other, level)) frame in
          upvar' level frame' xs
        | _ -> frame
      in
      let frame::xs = interp.frames in
      let frame' = upvar' level' frame pairs in
      {interp with frames = frame'::xs}
  in
  let procs = ["puts", puts; "set", set; "proc", proc; "global", global; "upvar", upvar] in
  {interp with procs = procs}

let inch = open_in Sys.argv.(1);;
let instr = Stream.of_channel inch;;
let interp = register_builtins initial_interp;;
eval interp initial_state instr

[1] http://code.google.com/p/hiccup/
[2] http://blog.so-net.ne.jp/rainyday/2006-10-21