unknown コマンドの使いどころ

Tcl から Lua を呼ぶバインディング [1] は Tcl の中括弧記法の特性のおかげでかなり Tcl と Lua を自然に融合しているが、定義した Lua の関数を呼ぶところで lua::call を呼ばなければならない。名前空間をインポートしても call は残ってしまう。Lua で print("hello") と書くところを Tcl/Lua だと call print hello と書くわけでこれはあまり美しくない。

そういうときに役に立つのが unknown コマンドである。前回の記事 [2] でも書いたように、これを使うと読んだコマンドが未定義だった時の動作を与えることができるので、以下のようなコードを書いてあげればよい。

% package require lua
1.00
% rename unknown _unknown
% proc unknown {name args} {
  if {[lua::funexist $name]} {
    eval lua::call $name $args
  } else {
    eval _unknwon $name $args
  }
}
% print hello
hello
% math.sin 3
0.14112000805987
%

ここで lua::funexist は新たに作成したコマンドで、引数で与えた名前が Lua の関数として存在するかどうかをチェックする。そこでもし存在した場合は lua::call に引き続いてそのコマンドを呼ぶのだ。Lua 関数としても無かった場合は退避しておいた既存の unknown コマンドに処理を委譲する。

このようにすることで Lua で定義した関数は Tcl のプロシージャと全く同様の構文で呼ぶことができるようになる。

以下は書きなおしたコード。

#include <stdio.h>
#include <assert.h>
#include <stdlib.h>
#include "tcl.h"
#include "lua.h"
#include "lauxlib.h"
#include "lualib.h"

#define LUA_ENTER(L)    int __stacksize = lua_gettop(L)
#define LUA_RETURN(L,X) assert(__stacksize == lua_gettop(L));return X

static int luaHandleProc(ClientData data, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[])
{
  int length;
  int error;
  char* luacode;
  lua_State* L = (lua_State*)data;
  LUA_ENTER(L);

  if(objc != 2){
    Tcl_WrongNumArgs(interp, 1, objv, "luacode");
    LUA_RETURN(L, TCL_ERROR);
  }

  luacode = Tcl_GetStringFromObj(objv[1], &length);
  error = luaL_loadbuffer(L, luacode, length,"tclua") || lua_pcall(L, 0, 0, 0);
  if (error) {
    Tcl_SetObjResult(interp, Tcl_NewStringObj(lua_tostring(L, -1), -1));
    lua_pop(L, 1);
    LUA_RETURN(L, TCL_ERROR);
  }

  Tcl_SetObjResult(interp, Tcl_NewStringObj("", -1));
  LUA_RETURN(L, TCL_OK);
}

/*
  push_function

  return value:
    0=success, 1=fail

  side effect:
    push a function on the stack when succeeded,
    set the Tcl result when failed.
*/
static int push_function(lua_State* L, Tcl_Interp* interp, const char* funname)
{
  /* push function name */
  if (strchr(funname, '.') == NULL) {
    /* if it's a global function, just push it */
    lua_getglobal(L, funname);
  } else {
    /* if the function is contained in a module(=table) ... */
    int argc = 0;
    char** argv = NULL;
    int i;
    size_t length = strlen(funname);
    char* buf = malloc(length+256);

    sprintf(buf, "split %s .", funname);
    Tcl_Eval(interp, buf);
    Tcl_SplitList(interp, Tcl_GetStringResult(interp), &argc, &argv);

    lua_getglobal(L, argv[0]);
    for (i = 1; i < argc; i++) {
      if (!lua_istable(L, -1)) {
        lua_pop(L, 1);
        Tcl_ResetResult(interp);
        Tcl_AppendResult(interp, "attempt to index a non-table value: ", argv[i-1], NULL);
        return 1;
      }
      lua_getfield(L, -1, argv[i]);
      lua_remove(L, -2); /* remove the indexee table from the stack */
    }
    Tcl_Free((char *)argv);
    free(buf);
  }
  return 0;
}

static int callHandleProc(ClientData data, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[])
{
  char* funname;
  int i;
  int argsbegin = 1;
  int resultc = 1;
  char** resultv = NULL;
  lua_State* L = (lua_State*)data;
  LUA_ENTER(L);

  if(objc < 2){
    Tcl_WrongNumArgs(interp, 1, objv, "funName ?-result varName...? ?arg...?");
    LUA_RETURN(L, TCL_ERROR);
  }

  if (strcmp(Tcl_GetString(objv[argsbegin]), "-result") == 0) {
    Tcl_SplitList(interp, Tcl_GetString(objv[argsbegin + 1]), &resultc, &resultv);
    argsbegin += 2;
  }

  funname = Tcl_GetString(objv[argsbegin]);
  if (push_function(L, interp, funname)) {
    LUA_RETURN(L, TCL_ERROR);
  }
  argsbegin++;

  /* push arguments */
  for (i = argsbegin; i < objc; i++) {
    char* arg;
    size_t length;
    arg = Tcl_GetStringFromObj(objv[i], &length);
    lua_pushlstring(L, arg, length);
  }

  /* call the function */
  if (lua_pcall(L, i - argsbegin, resultc, 0)) {
    Tcl_SetObjResult(interp, Tcl_NewStringObj(lua_tostring(L, -1), -1));
    lua_pop(L, 1);
    LUA_RETURN(L, TCL_ERROR);
  }

  if (resultv == NULL) {
    size_t length;
    const char* result = lua_tolstring(L, -1, &length);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1));
    lua_pop(L, 1);
    LUA_RETURN(L, TCL_OK);
  } else {
    int i;
    for (i = resultc -1 ; i >= 0; i--) {
      size_t length;
      const char* result = lua_tolstring(L, -1, &length);
      Tcl_SetVar(interp, resultv[i], result, 0);
      lua_pop(L, 1);
    }
    Tcl_Free((char *)resultv);
    LUA_RETURN(L, TCL_OK);
  }
}

static int funexistHandleProc(ClientData data, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[])
{
  char* funname;
  lua_State* L = (lua_State*)data;
  LUA_ENTER(L);

  if(objc != 2){
    Tcl_WrongNumArgs(interp, 1, objv, "funName");
    LUA_RETURN(L, TCL_ERROR);
  }

  funname = Tcl_GetString(objv[1]);
  if (push_function(L, interp, funname)) {
    Tcl_SetObjResult(interp, Tcl_NewStringObj("0", -1));
  } else {
    if (lua_isfunction(L, -1)) {
      Tcl_SetObjResult(interp, Tcl_NewStringObj("1", -1));
    } else {
      Tcl_SetObjResult(interp, Tcl_NewStringObj("0", -1));
    }
    lua_pop(L, 1);
  }
  LUA_RETURN(L, TCL_OK);
}

void Tclua_ExitProc(ClientData clientData)
{
  lua_State* L = (lua_State*)clientData;
  lua_close(L);
}

DLLEXPORT int Tclua_Init(Tcl_Interp* interp)
{
  lua_State* L = luaL_newstate();
  Tcl_CreateExitHandler(Tclua_ExitProc, (ClientData)L);
  luaL_openlibs(L);
  Tcl_InitStubs(interp, "8.1", 0);
  Tcl_CreateObjCommand(interp, "::lua::lua", luaHandleProc, (ClientData)L, NULL);
  Tcl_CreateObjCommand(interp, "::lua::call", callHandleProc, (ClientData)L, NULL);
  Tcl_CreateObjCommand(interp, "::lua::funexist", funexistHandleProc, (ClientData)L, NULL);
  if (Tcl_Eval(interp, "namespace eval lua { namespace export * }") == TCL_ERROR) return TCL_ERROR;
  return Tcl_PkgProvide(interp, "lua", "1.00");
}

[1] http://blog.so-net.ne.jp/rainyday/2006-11-05-1
[2] http://blog.so-net.ne.jp/rainyday/2006-11-12

Tcl から Lua を呼ぶバインディング

できた。

#include <stdio.h>
#include <assert.h>
#include <stdlib.h>
#include "tcl.h"
#include "lua.h"
#include "lauxlib.h"
#include "lualib.h"

#define LUA_ENTER(L)    int __stacksize = lua_gettop(L)
#define LUA_RETURN(L,X) assert(__stacksize == lua_gettop(L));return X

static lua_State* L = NULL;

static int luaHandleProc(ClientData data, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[])
{
  int length;
  int error;
  char* luacode;
  LUA_ENTER(L);

  if(objc != 2){
    Tcl_WrongNumArgs(interp, 1, objv, "luacode");
    LUA_RETURN(L, TCL_ERROR);
  }

  luacode = Tcl_GetStringFromObj(objv[1], &length);
  error = luaL_loadbuffer(L, luacode, length,"tclua") || lua_pcall(L, 0, 0, 0);
  if (error) {
    Tcl_SetObjResult(interp, Tcl_NewStringObj(lua_tostring(L, -1), -1));
    LUA_RETURN(L, TCL_ERROR);
  }

  Tcl_SetObjResult(interp, Tcl_NewStringObj("", -1));
  LUA_RETURN(L, TCL_OK);
}

static int callHandleProc(ClientData data, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[])
{
  char* funname;
  int i;
  int argsbegin = 1;
  int resultc = 1;
  char** resultv = NULL;
  int stacksize = lua_gettop(L);
  LUA_ENTER(L);

  if(objc < 2){
    Tcl_WrongNumArgs(interp, 1, objv, "funName ?-result varName...? ?arg...?");
    LUA_RETURN(L, TCL_ERROR);
  }

  if (strcmp(Tcl_GetString(objv[argsbegin]), "-result") == 0) {
    Tcl_SplitList(interp, Tcl_GetString(objv[argsbegin + 1]), &resultc, &resultv);
    argsbegin += 2;
  }

  /* push function name */
  if (strchr(Tcl_GetString(objv[argsbegin]), '.') == NULL) {
    /* if it's a global function, just push it */
    funname = Tcl_GetString(objv[argsbegin]);
    lua_getglobal(L, funname);
  } else {
    /* if the function is contained in a module(=table) ... */
    int argc = 0;
    char** argv = NULL;
    int i;
    size_t length = strlen(Tcl_GetString(objv[argsbegin]));
    char* buf = malloc(length+256);

    sprintf(buf, "split %s .", Tcl_GetString(objv[argsbegin]));
    Tcl_Eval(interp, buf);
    Tcl_SplitList(interp, Tcl_GetStringResult(interp), &argc, &argv);

    lua_getglobal(L, argv[0]);
    for (i = 1; i < argc; i++) {
      if (!lua_istable(L, -1)) {
        lua_pop(L, 1);
        Tcl_ResetResult(interp);
        Tcl_AppendResult(interp, "attempt to index a non-table value: ", argv[i-1], NULL);
        LUA_RETURN(L, TCL_ERROR);
      }
      lua_getfield(L, -1, argv[i]);
      lua_remove(L, -2); /* remove the indexee table from the stack */
    }
    free(buf);
  }
  argsbegin++;

  /* push arguments */
  for (i = argsbegin; i < objc; i++) {
    char* arg;
    size_t length;
    arg = Tcl_GetStringFromObj(objv[i], &length);
    lua_pushlstring(L, arg, length);
  }

  /* call the function */
  if (lua_pcall(L, i - argsbegin, resultc, 0)) {
    Tcl_SetObjResult(interp, Tcl_NewStringObj(lua_tostring(L, -1), -1));
    lua_pop(L, 1);
    LUA_RETURN(L, TCL_ERROR);
  }

  if (resultv == NULL) {
    size_t length;
    const char* result = lua_tolstring(L, -1, &length);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1));
    lua_pop(L, 1);
    LUA_RETURN(L, TCL_OK);
  } else {
    int i;
    for (i = resultc -1 ; i >= 0; i--) {
      size_t length;
      const char* result = lua_tolstring(L, -1, &length);
      Tcl_SetVar(interp, resultv[i], result, 0);
      lua_pop(L, 1);
    }
    Tcl_Free((char *)resultv);
    LUA_RETURN(L, TCL_OK);
  }
}

DLLEXPORT int Tclua_Init(Tcl_Interp* interp){
  L = luaL_newstate();
  luaL_openlibs(L);
  Tcl_InitStubs(interp, "8.1", 0);
  Tcl_CreateObjCommand(interp, "::lua::lua", luaHandleProc, NULL, NULL);
  Tcl_CreateObjCommand(interp, "::lua::call", callHandleProc, NULL, NULL);
  if (Tcl_Eval(interp, "namespace eval lua { namespace export * }") == TCL_ERROR) return TCL_ERROR;
  return Tcl_PkgProvide(interp, "lua", "1.00");
}

これを使うと以下のように Tcl と Lua を融合したコードが書ける。

package require lua
namespace import ::lua::*

lua {
  -- lua code begin
  function f(x)
    return x*2
  end

  -- function with multiple results
  function g(x)
    return x^2,x^3
  end

  x = {}
  x.y = {}
  x.y.f = f
}

puts "f(12)=[call f 12]"
call -result {r s} g 12
puts "g(12)=$r, $s"
puts "math.sin(1)=[call math.sin 1]"
puts "x.y.f(13)=[call x.y.f 13]"

実行結果。

f(12)=24
g(12)=144, 1728
math.sin(1)=0.8414709848079
x.y.f(13)=26

次の目標は Tcl と Lua の変数を行き来しやすくすることだな。

Tcl 8.5 の expr コマンド関係

まだ続く Tcl 8.5 シリーズ。

Tcl 8.5 では expr の中で使える演算子に in と ni が使えるようになった。
expr というと Tcl で数学的な計算を行うときに使うものというイメージがあるけど if の条件節を評価するときに内部的に使われているコマンドでもある。
in と ni は数学計算というよりは if の中での使用を念頭に置いた演算子で、「a in b」は「リスト b の中に a が存在する場合真、それ以外は偽」ということになる。「a ni b」はその逆。いままで foreach とか使って泥臭く書いていたのがこうかけるようになる。

% set l {a b c}
a b c
% if {"a" in $l} {puts hit}
hit
% if {"d" in $l} {puts hit}
%

Python とか awk の in 演算子と同じということですね。

そして expr の中で使える数学関数をユーザ定義できるようになった。今度からは expr は tcl::mathfunc 名前空間の中に定義されたプロシージャを関数として使う。

% proc tcl::mathfunc::gcd {m n} {
      if {$m == 0} {
              return $n
      } else {
              return [gcd [expr $n % $m] $m]
      }
}
% expr gcd(5499,6812)
13

今まで同様のことをやるときはコマンド置換を駆使しなければならず数式が見えにくくなっていたのが、これにより普通の関数っぽく見えるようになってすっきりする。

Tcl 8.5 の {expand}

Tcl 8.5 で新たに {expand} という表記が導入された。これはコマンドの追加ではなく、Tcl のコマンド解釈の方法に対する変更である。

これはこのようにして使う。

% {expand}{puts hello}
hello

何が起こっているかわかるだろうか。もうひとつ例を挙げる。

% set greeting {Hello World}
Hello World
% list $greeting
{Hello World}
% list {expand}$greeting
Hello World

list コマンドは可変長の引数をとり、それをリスト化（空白で区切られた文字列）したものを返すコマンドだが、2つ目のコード例の最初の list コマンドでは変数 $greeting の中身が空白で区切られていようとも list コマンドに対して与えられた引数は1つなので「Hello World」という空白入りの要素が1つだけ含まれたリストを返す。空白を含むリスト要素は中括弧で括られる。

次の {expand} を使った例では、まず {expand} に続く内容がコマンドラインの要素として展開される。だからこのコマンドは以下と等価になる。

% list Hello World
Hello World

最初のコード例に戻ろう。この puts hello は中括弧でグルーピングされているから本来ならコマンドライン上の1要素として解釈されるはずだ。

% {puts hello}
invalid command name "puts hello"

コマンドラインの最初の要素はコマンドだから「puts hello」というコマンドがない限りは上記のエラーになる。[1]

ところがもし要素が {expand} という修飾子（と呼ぶのかなんと呼ぶのか）で始まっていたら続く中身がコマンドライン上に展開される。従って「{expand}{puts hello}」は以下のコマンドと等価になるというわけだ。

% puts hello
hello

しかし何故こんなものが導入されたのだろうか。

今までは (1) list コマンドのように可変長の引数リストをとって何かをするコマンドがあり、(2) そのコマンドに与えたいリストが Tcl リストとして存在する場合、以下のように eval を使う必要があった。

% eval list $greeting
Hello World

さもなくば先に見たようにリストが単一の引数としてコマンドに与えられてしまうからだ。上記の eval を使う方法の代替が「list {expand}$greeting」ということになる。

だがこの表記の導入がいいものかどうかは疑問が残る。文法の追加は Tcl の簡潔性を次第に損なっていくものだし、これは別に 8.4 までの仕様でできないことではなく、いわば syntactic sugar のようなものだ。

まあそれにしてもいまさら 8.5 の新機能を一つ一つ試しているというのも1～2年くらい遅れているということなので tcl-core とかにちゃんと subscribe したほうがいいのかもしれない。

[1] 余談だが Tcl では空白を含む名前のプロシージャを定義することもできる。

% proc {puts hello} {} {
puts hello
}
% {puts hello}
hello
%

Tcl 8.5 の dict コマンド(本編)

一つ前の記事では Tcl の array が全体として文字列ではなく、従ってプロシージャ間でそのまま値としては受け渡せないということを見た。

Tcl 8.5 で導入された dict は辞書に対する操作を提供するコマンドである。辞書とは前回の記事で「array をシリアライズしたリスト」といっていたものに相当する。

キーから値を取り出す dict get は以下のように使える。

% dict get {key1 value1 key2 value2} key1
value1
% dict get {key1 value1 key2 value2} key2
value2

array とは異なり辞書は通常のひとつの変数にそのまま収まり、かつそのまま dict コマンドで操作できる。

% set d1 {key1 value1 key2 value2}
key1 value1 key2 value2
% dict get $d1 key1
value1
% dict get $d1 key2
value2

キーに対応する値を設定する場合は dict set を使う。辞書が dict コマンドにより操作された場合の順序性は保証されない。

% dict set d1 key3 value3
key3 value3 key1 value1 key2 value2
% dict set d1 key3 value_three
key3 value_three key1 value1 key2 value2

そのほか各種ユーティリティコマンドが dict のサブコマンドとして提供されている。
array との違いで興味深いのは辞書はネストできるという点だ。array はネストできない。次のコマンドは一見動くように見える。

% set a(1)(2) a
a

だが騙されてはいけない！

% array names a
1)(2

Tcl の array で二次元配列のようなことをする場合は a(1,2) のような記法を使用するのが普通で、この「1,2」のコンマは単なる慣例である。

一方、先の dict set は実はキーを複数とることができて、その場合ネストされた辞書に対する操作とされる。

% dict set d2 lv1 lv2 value
lv1 {lv2 value}

これは辞書 d2 の lv1 キーに対応する値が辞書であり、その内側の辞書の lv2 キーに対応する値が value であるということになる。

dict get も同様に複数のキーを取れる。次の例の2つ目のコマンドは3つ目と等価だ。

% dict get $d2 lv1
lv2 value
% dict get $d2 lv1 lv2
value
% dict get [dict get $d2 lv1] lv2
value

ところでこの「lv1 {lv2 value}」というのはインタラクティブシェルの pretty printing の結果ではなく、あくまでそのまま文字列として扱えるものだということに注意したい。

% regsub -all { } $d2 _ s
2
% puts $s
lv1_{lv2_value}
% append d2 { newkey newvalue}
lv1 {lv2 value} newkey newvalue
% dict get $d2 newkey
newvalue

さて、前回解説したように array にはプロシージャ間で受け渡しができないという問題点があった。dicｔ は文字列である。文字列は受け渡しできる。

% proc take_dict v {
        set a [dict get $v 1]
        puts "$a"
}
% set d3 {1 one 2 two}
1 one 2 two
% take_dict $d3
one
% proc return_dict {} {
        return [dict create 1 one 2 two]
}
% set r [return_dict]
1 one 2 two
% dict get $r 1
one
% dict get $r 2
two

dict の導入は Tcl にパワフルな機能をもたらすものだ。連想配列に極めて広範囲な利用法があるということについては Lua に例がある。そして Tcl 哲学の「すべては文字列である」と結びつくことでさらなる可能性が開ける。例えば文字列である辞書はそのままファイルに永続化してそのままロードできる。

% set f [open tmp w]
file9f5098
% puts -nonewline $f $d3
% close $f
% type tmp; # Unix なら cat
1 one 2 two%
% set f [open tmp]
filea0f5b8
% set d4 [gets $f]
1 one 2 two
% close $f
% dict get $d4 1
one
% dict get $d4 2
two

Programming in Lua の12章には Lua のテーブルを Lua コードとして永続化してそのコードを走らせることで再利用する技法が紹介されているが、Tcl のこの方法はそれよりもはるかに平明だ。

Tcl 8.5 の dict コマンド（予告編）

Tcl 8.5 コマンドレビューの第3回目として dict コマンドについて見ていく。

これは名前から想像されるように連想配列を扱うためのコマンドだ。だけど Tcl には既に array という連想配列がある。何が違うのか。それを比較するためにまずは既存の array の特性について、特にその使いにくさについて復習しよう。

Tcl では array は以下のように括弧で添字を囲むよくありがちな表記法で利用できる。

% set v(1) foo
foo
% set v(2) bar
bar
% puts $v(1)
foo
% puts $v(2)
bar

なお「(」や「)」はTclの変数名として使用が禁じられているわけではない。

% set a( 1
1
% set a) 2
2

確かに次のように変数展開をしようとすると予期しない結果になる。

% puts $a)
can't read "a": no such variable

しかしこれは変数名に対する制約というよりは変数展開時の解析方法の制約である。ドル記号を使った通常の変数の置き換えでは英数字（と「_」と「::」）の続くところまでを変数名とみなすので「$a」を展開したものと「)」という文字の連続とみなされているだけだ。これは以下のような中括弧を使った記法で回避できる。

% puts ${a)}
2

ここまで読んで Tcl のミニマリズムについて聞かされた事のある人はこう思うかもしれない。なるほど、Tcl では連想配列といっても実は他の変数と同様の変数定義の束であり、単に慣習により var(index) という形の名前をとるだけとみなすことができるのではないか。

これは正しくない。まず括弧の組を使った変数の置き換えは Tcl のパーサにより特別扱いされる。括弧の中ではさらなる変数置き換えやコマンド置き換えが許される。

% set ver [info tclversion]
8.5
% set v(8.5) foo
foo
% puts $v($ver)
foo
% puts $v([info tclversion])
foo

また一度配列名として使われた名前は普通の変数としては使えなくなる。

% set v bar
can't set "v": variable is array

しかし一方で Tcl の array が変数の束であるという見方が妥当だと思える点もある。array はプロシージャの引数や戻り値として受け渡しできない。

% proc take_array v {
        puts $v(1)
}
% take_array $v
can't read "v": variable is array
% proc return_array {} {
        set v(tcl) 8.5
        return $v
}
% return_array
can't read "v": variable is array

Tcl で引数や戻り値になりうるのは文字列だけであるということを思い出そう。array は全体として文字列ではないのだ。実のところこれが Tcl の EIAS ドグマと相容れるものなのかはかなり疑問である。ともかく array にはこのような使いにくさがあり、しばしば混乱を招くものだった。

では array を受け渡ししたい場合はどうすればよいのか。方法は2通りある。
ひとつは array をリストに「シリアライズ」する方法。リストは何ら後ろめたいところ無く文字列なので受け渡しできる。

% proc take_array l {
        array set v $l
        puts "v(1) is $v(1)"
}
% array get v
1 foo 2 bar 8.5 foo
% take_array [array get v]
v(1) is foo
%
%
% proc return_array {} {
        set v(1) blablah
        return [array get v]
}
% return_array
1 blablah
% array set r [return_array]
% puts $r(1)
blablah

array get は与えられた名前の配列から「添字 値 添字 値 ...」というリストを作る。array set はその逆でリストから配列に内容を設定する。

2つ目の方法はいわば「参照渡し」で、配列の名前を渡してプロシージャの中で upvar する方法だ。

% proc take_array {v} {
        upvar 1 $v myvar
        puts "myvar(1) is $myvar(1)"
}
% take_array v
myvar(1) is foo

「upvar 1 otherVar myVar」は呼び出し元に向かって1レベル上に辿って（つまり直接の呼び出し元）、そのレベルに存在する変数 otherVar の別名を myVar とする。

以上 Tcl の既存の array の使いにくさについて書いた。それは
(1) 純粋に文字列ではない
(2) プロシージャ間で受け渡しできない
という特徴を持つ。

新たに Tcl 8.5 に導入された dict はこうした特性のかなりの部分を解消するものである。続く。

Tcl 8.5 の lassign で多重代入

以前 Tcl には多重代入がないといって自分で実装 [1] していた裏ではすでに開発中の 8.5 で lassign コマンドが導入されていた。安定版じゃなくてもちゃんとチェックしていないと余計なことを書くはめになるということだ。

lassign list varName ?varName ...?

私が作ったのとは違って、リストが先に来て変数が後に来る。他にも (1) リストの要素数より変数名が多い場合は "" が代入されるとか、(2) 変数名の方が少ない場合はリストの「残り」がコマンドの戻り値になる、とかいうボーナス機能がある。
Tcl 8.5 の lassign は C で実装されているようだが、前回と同様 Pure Tcl でも以下のように書ける。

% proc lassign {l args} {
for {set i 0} {$i < [llength $args]} {incr i} {
  set var [lindex $args $i]
  set val [lindex $l $i]
  uplevel 1 [list set $var $val]
}
return [lrange $l $i end]
}
% lassign {a b c} x y z
% puts $x; puts $y; puts $z
a
b
c
% lassign {d e} x y z
% puts $x; puts $y; puts $z
d
e

% lassign {f g h i} x y
h i
% puts $x; puts $y
f
g

Tcl 8.5 ではもうひとつ lrepeat というリストコマンドが追加になっている。これは名前から予想されるとおりリストを指定回数繰り返して新しいリストを返す。

[1] http://blog.so-net.ne.jp/rainyday/2006-07-28

Tcl8.5 の apply コマンドで関数型プログラミング

私はこれまではまだ Tcl8.4 をメインにしていて 8.5 の機能をあまり触っていないことに気がついたので新機能を試してみることにしたい。

まずは新規追加になった apply コマンド。これは端的に言うと Tcl で関数型プログラミングへの道を開くものだ。

プログラミング言語のデザインでは「なんでも○○」という原則を作ることで仕様を簡潔にするということがしばしば行われている。○○に入るのは「オブジェクト」だったり「S式」だったりするかもしれない。Tcl ではそこに「文字列」が入る。Tcl という言語におけるファーストクラスは文字列のみであり（EIAS: Everything Is A String）、Tcl の魅力と奇怪さの多くはここから来ている。

さて、 Tcl ではプロシージャ（＝関数）は通常の変数とは別の名前空間を持ち、また通常の変数への代入はできない。
例えば Lua や OCaml では funtion f (x) ... や let f x = ... は f = function(x) ... や let f = function x -> ... と同等であるのに対して、 Tcl の proc f {x} {...} は set コマンドでは置き換えられない。プロシージャを作ることとそれに名前をつける事は proc コマンドの中で結びついている。別の言い方をすると無名関数を作ることができない（これまではできなかった）。

勿論 EIAS 原則に基づけばプロシージャも文字列である。例えば次のように書いてプロシージャを定義するときは「x」という文字列と「puts "Hello, $x"」という文字列を引数に与えて「proc コマンド」を呼んでいるのだ。

% proc say_hello_to x {puts "Hello, $x"}

定義した後も info args と info body を使えば定義済みのプロシージャの中身を文字列として得ることができる。

% info args say_hello_to
x
% info body say_hello_to
puts "Hello, $x"

さて、文字列は受け渡しすることができるのだから高階関数のような技法もこれまでの仕組みでまったく不可能というわけではない。

% proc do_something_on_7 {a b} {
proc tmpf $a $b
tmpf 7
}
% do_something_on_7 x {expr $x*2}
14
% do_something_on_7 x {expr pow($x,2)}
49.0

このプロシージャは「渡された関数」を呼ぶために、引数で与えられた引数列 a と本体 b を使って内部で tmpf というプロシージャを定義している。
この方法の問題点はこの一時プロシージャの名前が既存の定義と衝突するかもしれないということだ。名前空間を分けるなどのトリックで衝突の危険を減らすことはできるかもしれない。しかしそれはその分だけ手間がかかるということだし、問題を綺麗さっぱり忘れてよくなるというわけではない。「名前の付けられたプロシージャしかプロシージャとして呼び出すことはできない」という制約がある限りは。

apply コマンドはこの問題を解決する。これを使うと上記の do_something_on_7 は以下のように書ける。

% proc do_something_on_7 {args} {
apply $args 7
}

これにより一時的な名前などは気にすることなくプロシージャを呼ぶことができるというわけだ。

今まで例えば tcllib の struct::list map なんかは関数渡しもどきの部分が制約の多いかなりいまいちな仕様になっていたのだけど 8.5 対応すれば自然な書き方ができるようになるだろう。

% proc map {l args} {
  set res [list]
  foreach item $l {
    lappend res [apply $args $item]
  }
  return $res
}
% map {1 2 3 4 5} x {expr $x*2}
2 4 6 8 10
%

Tcl(/Tk) でグラフ

Lightweight Language のサイトの「キミならどう書く 2.0 - ROUND 3 -」というトラックバック企画 [1] で今回のお題が「いくつかのデータを与えたときにグラフを出力するプログラム」（細かい仕様無し）ということだった。

今までこの企画で Tcl や Tcl/Tk で参加している人は意外にもいないっぽいので書いてみることにしました（それにこのお題はいかにも Tcl/Tk 向き）。

まずちょっと仕様を制限したもの。キャンバスの幅をはみ出すようなデータは考慮しない。

# graph.tcl
pack [canvas .canvas -width 200 -height [expr 20*[llength $argv]] -bg white]
set ypos 10
foreach num $argv {
  .canvas create line 0 $ypos [expr $num*10] $ypos -width 18 -fill blue
  .canvas create text 2 $ypos -text $num -anchor w -fill white
  incr ypos 20
}

実行するには

wish graph.tcl 2 5 9 18 15

などとする。実行結果はこうなる。

次はちゃんとキャンバスの大きさに合わせて伸縮するようにしたもの。

# graph2.tcl
set height 150; set width 200; # キャンバスの大きさ

set max [lindex [lsort -integer $argv] end]; # 要素の最大値
set lwidth [expr $height/[llength $argv]]; # 線の取れる太さ

pack [canvas .canvas -width $width -height $height -bg white]

set ypos [expr $lwidth/2]
foreach num $argv {
  set xpos [expr $width*$num/$max]
  .canvas create line 0 $ypos $xpos $ypos -width [expr $lwidth-2] -fill blue
  .canvas create text $xpos $ypos -text $num -anchor e -fill white
  incr ypos $lwidth
}

実行結果は以下のとおり。

wish graph2.tcl 2 5 9 30 18 15

しかしここまでだと何のひねりもなくて、単なる Tcl/Tk 入門みたいな話になってしまう。そして「***/Tk ならもっとスマートに書ける。なんだその expr は」とか言われそうだ。

こういう企画は「そんなものを使ってグラフを表現するなんて！」とか「おっと、そんな書き方があったか」とか「ここはワンライナーで」みたいな部分が面白みだと思うので Tk なしの Tcl 版で1行で収まるように書いてみたものを最後に紹介します（とはいえ tclsh には awk や perl のようにコマンド引数から直接プログラムを与える書き方はない）。

eval [regsub -all {(\d+)} $argv {puts [format "%2d : " \1][string repeat * \1];}]

実行結果はこんな風。

F:\>tclsh graph3.tcl 2 5 9
 2 : **
 5 : *****
 9 : *********

ループ構文が出てこないところがちょっといい感じ（かな？）。

[1] http://ll.jus.or.jp/2006/blog/doukaku3

プログラム言語系統樹における Tcl

いろいろウェブサイトを読みまわっていたら Computer Language History [1] というプログラム言語の系統樹のページにたどり着いた。こういうのを眺めるのは楽しいのだが、我がお気に入り言語の Tcl のところで思わず笑ってしまった。

Tcl は1988年に他の言語の影響をまったく受けずに生まれ、現在に至るまで他の言語にまったく影響を与えずに一直線に進化している！

こういう言語が他にもあるかとおもって探してみたら Prolog だけだった。

もっとも、他の言語に影響を与えていないというのはともかくとして、Tcl の基本的な構文は普通に考えてシェルスクリプトを踏襲しているし tclsh もある程度既存シェルを置き換えるような意図が感じられる（例えば対話モードでは外部コマンドが exec 無しで実行できる）ので sh (1969) からの線が引かれていてもよいはずである。

[1] http://www.levenez.com/lang/