目次 前 次

---

FORTHシステム(Tcl/Tk)

　新しいマイコンの勉強をする場合、アセンブリ言語しか
　用意されていない場合があります。

　アセンブリ言語で簡単な処理系を構成する場合、構文解析が
　簡単なFORTHインタプリタを作成して利用することが多いです。

　スタック操作ができると、proper programを書きやすいので
　内蔵SRAMが4kバイト程度あれば、マイコンのハードウエアを
　テストする、小規模なOSなしのシステムを作成する等では
　FORTH利用で、作成しやすく、それなりに使えるシステムを
　構築できます。

　アセンブリ言語でいきなりFORTHシステムを作成するのは
　開発時間が長くなるため、Unix、Windowsの双方で使える
　Tcl/Tkのスクリプトで作成しました。

　コマンドラインから、コマンドとパラメータを
　入力するのは面倒なので、テキストファイルに
　次のような文字列を用意して確認することに。

1 2 + .
4 5 * .
10 1 2 - .
1 2 * 3 4 5 + .
9 2 / .
9 2 % .
100 10 inc .
100 22 dec .
1 dup . .
12 24 + . cr
10 0 < .
10 0 <= .
10 0 > .
10 0 >= .
10 10 == .
10 10 != .
10 0 < if 0 1 + . then
10 11 < if 2 3 + . then
10 0 <= if 0 1 + . else 4 3 * . then
10 0 >= if 0 1 + . else 4 1 - . then
10 0 == if 2 3 + . else 5 1 - . then
3 0 do I inc dec . loop
11 1 do I . loop
1 2 3 4 drop drop . .
3 3 == if 100 . else 0 . then
3 4 == if 100 . else 200 . then
3 4 >= if 100 . else 200 . then
: mul10 10 * ;
: mul3 3 * ;
: mulx 2 * 1 + ;
9 mul3 .
9 mulx .
1 2 3 4 drop drop . .
10 9 8 7 rot . . . .
1 << .
8 << .
15 3 & .
15 16 | .
15 3 ^ .
1 2 3 20 4 max .
10 2 3 20 4 min .
var aa 123 aa ! 321 aa !
aa @ .
0 3 2 -5 min .
0 3 2 -5 max .

　作成したFORTHシステムで、動作確認すると、以下となりました。

>1 2 + .
3
>4 5 * .
20
>10 1 2 - .
7
>1 2 * 3 4 5 + .
14
>9 2 / .
4
>9 2 % .
1
>100 10 inc .
11
>100 22 dec .
21
>1 dup . .
1
1
>12 24 + . cr
36

>10 0 < .
0
>10 0 <= .
0
>10 0 > .
1
>10 0 >= .
1
>10 10 == .
1
>10 10 != .
0
>10 0 < if 0 1 + . then
>10 11 < if 2 3 + . then
5
>10 0 <= if 0 1 + . else 4 3 * . then
12
>10 0 >= if 0 1 + . else 4 1 - . then
1
>10 0 == if 2 3 + . else 5 1 - . then
4
>3 0 do I inc dec . loop
0
1
2
>11 1 do I . loop
1
2
3
4
5
6
7
8
9
10
>1 2 3 4 drop drop . .
2
1
>3 3 == if 100 . else 0 . then
100
>3 4 == if 100 . else 200 . then
200
>3 4 >= if 100 . else 200 . then
200
>: mul10 10 * ;
 mul10
>: mul3 3 * ;
 mul10 mul3
>: mulx 2 * 1 + ;
 mul10 mul3 mulx
>9 mul3 .
27
>9 mulx .
19
>1 2 3 4 drop drop . .
2
1
>10 9 8 7 rot . . . .
8
9
7
10
>1 << .
2
>8 >> .
4
>15 3 & .
3
>15 16 | .
31
>15 3 ^ .
12
>1 2 3 20 4 max .
20
>10 2 3 20 4 min .
2
>var aa 123 aa ! 321 aa !
>aa @ .
321
>0 3 2 -5 min .
-5
>0 3 2 -5 max .
3

　450行程度で処理系を記述できました。
　スクリプトは以下。

# computing built-in instruction
proc cmd_execute {xcmd x} {
  # get parameters
  set car [lindex $x 0]
  set cdr [lrange $x 1 end]
  # ADD
  if { $xcmd == "+" } {
    foreach i $cdr {
      set car [expr $car + $i]
    }
  }
  # SUBTRACT
  if { $xcmd == "-" } {
    foreach i $cdr {
      set car [expr $car - $i]
    }
  }
  # MULTIPLY
  if { $xcmd == "*" } {
    foreach i $cdr {
      set car [expr $car * $i]
    }
  }
  # DIVIDE
  if { $xcmd == "/" } {
    foreach i $cdr {
      if { $i != 0 } {
        set car [expr $car / $i]
      }
    }
  }
  # REMAINDER
  if { $xcmd == "%" } {
    foreach i $cdr {
      if { $i != 0 } {
        set car [expr $car % $i]
      }
    }
  }
  # INCREMENT
  if { $xcmd == "inc" } {
    set car [expr $car + 1]
  }
  # DECREMENT
  if { $xcmd == "dec" } {
    set car [expr $car - 1]
  }
  # LESS THAN
  if { $xcmd == "<" } {
    set cdr [lindex $cdr 0]
    if { $car < $cdr } {
      set car 1
    } else {
      set car 0
    }
  }
  # LESS THAN or EQUAL
  if { $xcmd == "<=" } {
    set cdr [lindex $cdr 0]
    if { $car <= $cdr } {
      set car 1
    } else {
      set car 0
    }
  }
  # GREATER THAN
  if { $xcmd == ">" } {
    set cdr [lindex $cdr 0]
    if { $car > $cdr } {
      set car 1
    } else {
      set car 0
    }
  }
  # GREATER THAN or EQUAL
  if { $xcmd == ">=" } {
    set cdr [lindex $cdr 0]
    if { $car >= $cdr } {
      set car 1
    } else {
      set car 0
    }
  }
  # EQUAL
  if { $xcmd == "==" } {
    set cdr [lindex $cdr 0]
    if { $car == $cdr } {
      set car 1
    } else {
      set car 0
    }
  }
  # NOT EQUAL
  if { $xcmd == "!=" } {
    set cdr [lindex $cdr 0]
    if { $car != $cdr } {
      set car 1
    } else {
      set car 0
    }
  }
  # &
  if { $xcmd == "&" } {
    set cdr [lindex $cdr 0]
    set car [expr $car & $cdr]
  }
  # |
  if { $xcmd == "|" } {
    set cdr [lindex $cdr 0]
    set car [expr $car | $cdr]
  }
  # ^
  if { $xcmd == "^" } {
    set cdr [lindex $cdr 0]
    set car [expr $car ^ $cdr]
  }
  # <<
  if { $xcmd == "<<" } {
    set car [expr $car * 2]
  }
  # >>
  if { $xcmd == ">>" } {
    set car [expr $car / 2]
  }

  return $car
}

proc isvariable {x} {
  global varnametbl
  #
  set result 0
  # judge
  if { [lsearch -exact $varnametbl $x] >= 0 } {
    set result 1
  }

  return $result
}

proc interpret {x} {
  global wordnametbl wordstack varnametbl varstack
  # copy
  set xx $x
  # show
  puts ">$xx"
  # clear
  set result ""
  set ustack ""
  # replace word
  set yy ""
  foreach i $xx {
    # copy
    set tmp $i
    # ? word
    if { [lsearch -exact $wordnametbl $i] >= 0 } {
      set tmp $wordstack($i)
    }
    # update
    set yy "$yy $tmp"
  }
  set xx $yy
  # initialize
  set last 0
  set xcnt 0
  # loop
  set len [llength $xx]
  set ptr 0
  while { $ptr < $len } {
    # get token
    set i [lindex $xx $ptr]
    # ?digit
    if { [string is digit -strict $i] == 1 } {
      # store digit
      set ustack "$ustack $i"
      # increment
      incr ptr
    }
    if { [string length $i] > 1 && [string index $i 0] == "-" } {
      # store digit
      set ustack "$ustack $i"
      # increment
      incr ptr
    }
    # + , - , * , /
    if { $i == "+" || $i == "-" || $i == "*" || $i == "/" || $i == "%" } {
      # calculate stack top
      set result [cmd_execute $i $ustack]
      # poke
      set ustack $result
      # increment
      incr ptr
    }
    # inc
    if { $i == "inc" || $i == "dec" } {
      # calculate stack top
      set result [cmd_execute $i [lindex $ustack end]]
      # remove stack top
      set ustack [lrange $ustack 0 end-1]
      # add stack top
      set ustack "$ustack $result"
      incr ptr
    }
    # dup
    if { $i == "dup" } {
      # get stack top
      set result [lindex $ustack end]
      # add stack top
      set ustack "$ustack $result"
      # increment
      incr ptr
    }
    # cr
    if { $i == "cr" } {
      # show empty list
      puts ""
      # increment
      incr ptr
    }
    # < , <= , > , >= 
    if { $i == "<" || $i == "<=" || $i == ">" || $i == ">=" } {
      #
      set ptrl [lsearch -exact $xx $i]
      # judge
      if { [llength $ustack] >= 2 } {
        # calculate
        set result [cmd_execute $i [lrange $ustack end-1 end]]
        # remove 2 digit
        set ustack [lrange $ustack 0 end-2]
        # add result
        set ustack "$ustack $result"
      }
      # increment
      set ptr [expr $ptrl+1]
    }
    # == , != 
    if { $i == "==" || $i == "!=" } {
      #
      set ptrl [lsearch -exact $xx $i]
      # judge
      if { [llength $ustack] >= 2 } {
        # calculate
        set result [cmd_execute $i [lrange $ustack end-1 end]]
        # remove 2 digit
        set ustack [lrange $ustack 0 end-2]
        # add result
        set ustack "$ustack $result"
      }
      # increment
      set ptr [expr $ptrl+1]
    }
    # drop
    if { $i == "drop" } {
      # remove stack top
      set ustack [lrange $ustack 0 end-1]
      # increment
      incr ptr
    }
    # rot
    if { $i == "rot" } {
      set result ""
      # judge
      if { [llength $ustack] >= 3 } {
        # get stack top
        set fx [lindex $ustack end]
        set ustack [lrange $ustack 0 end-1]
        # get stack top
        set sx [lindex $ustack end]
        set ustack [lrange $ustack 0 end-1]
        # get stack top
        set tx [lindex $ustack end]
        set ustack [lrange $ustack 0 end-1]
        # append
        set ustack "$ustack $fx $tx $sx"
      }
      # increment
      incr ptr
    }
    # swap
    if { $i == "swap" } {
      set result ""
      # judge
      if { [llength $ustack] >= 2 } {
        # get stack top
        set fx [lindex $ustack end]
        set ustack [lrange $ustack 0 end-1]
        # get stack top
        set sx [lindex $ustack end]
        set ustack [lrange $ustack 0 end-1]
        # append
        set ustack "$ustack $fx $sx"
      }
      # increment
      incr ptr
    }
    # << , >> 
    if { $i == "<<" || $i == ">>"} {
      # calculate
      set result [cmd_execute $i [lindex $ustack end]]
      # remove stack top
      set ustack [lrange $ustack 0 end-1]
      # append
      set ustack "$ustack $result"
      # increment
      incr ptr
    }
    # & , | , ^
    if { $i == "&" || $i == "|" || $i == "^" } {
      set result ""
      # judge
      if { [llength $ustack] >= 2 } {
        # get stack top
        set sx [lindex $ustack end]
        set ustack [lrange $ustack 0 end-1]
        # get stack top
        set fx [lindex $ustack end]
        set ustack [lrange $ustack 0 end-1]
        # calculate
        set tmp "$fx $sx"
        set result [cmd_execute $i $tmp]
        # append
        set ustack "$ustack $result"
      }
      # increment
      incr ptr
    }
    # if
    if { $i == "if" } {
      # get result
      set result [lindex $ustack end]
      # remove stack top
      set ustack [lindex $ustack end-1]
      # else location
      set ptrelse [lsearch -exact $xx "else"]
      # judge
      if { $result == 1 } {
        # increment
        incr ptr
      } else {
        # update
        if { $ptrelse >= 0 } {
          set ptr [expr $ptrelse+1]
        } else {
          set ptr [lsearch -exact $xx "then"]
        }
      }
    }
    # else
    if { $i == "else" } {
      # update
      set ptr [lsearch -exact $xx "then"]
    }
    # then
    if { $i == "then" } {
      # increment
      incr ptr
    }
    # do
    if { $i == "do" } {
      # judge
      if { [llength $ustack] >= 2 } {
        # get end count
        set last [lindex $ustack end-1]
        # get start count
        set xcnt [lindex $ustack end]
        # remove 2 digit
        set ustack [lrange $ustack 0 end-2]
      }
      # increment
      incr ptr
    }
    # I
    if { $i == "I" } {
      # poke I(xcnt)
      set ustack "$ustack $xcnt"
      # increment
      incr ptr
    }
    # loop
    if { $i == "loop" } {
      # increment control counter
      set xcnt [expr $xcnt+1]
      # judge
      if { $xcnt < $last } {
        set ptrdo [lsearch -exact $xx "do"]
        set ptr [expr $ptrdo+1]
      } else {
        # increment
        incr ptr
      }
    }
    # word definition :
    if { $i == ":" } {
      # word name
      set wdn [lindex $xx [expr $ptr+1]]
      # memory
      set wordnametbl "$wordnametbl $wdn"
      # word body
      set wdbody [lrange $xx [expr $ptr+2] end-1]
      # store
      set wordstack($wdn) $wdbody
      # 
      set ptr [lsearch -exact $xx ";"]
    }
    # word definition ;
    if { $i == ";" } {
      puts $wordnametbl
      # increment
      incr ptr
    }
    # max
    if { $i == "max" } {
      # get first datum
      set result [lindex $ustack 0]
      # loop
      foreach i $ustack {
        # compare
        if { $result < $i } {
          set result $i
        }
      }
      # update
      set ustack "$ustack $result"
      # increment
      incr ptr
    }
    # min
    if { $i == "min" } {
      # get first datum
      set result [lindex $ustack 0]
      # loop
      foreach i $ustack {
        # compare
        if { $result > $i } {
          set result $i
        }
      }
      # update
      set ustack "$ustack $result"
      # increment
      incr ptr
    }
    # var
    if { $i == "var" } {
      # get variable name
      set varn [lindex $xx [expr $ptr+1]]
      # store variable name
      set varnametbl "$varnametbl $varn"
      # set pseudo value
      set varstack($varn) 0
      # increment
      set ptr [expr $ptr+2]
    }
    # .
    if { $i == "." } {
      # get stack top
      set result [lindex $ustack end]
      # delete
      set ustack [lrange $ustack 0 end-1]
      # show
      puts $result
      # increment
      incr ptr
    }
    # set value to variable
    if { $i == "!" } {
      # get variable name
      set varn [lindex $ustack end]
      # get variable
      set result [lindex $ustack end-1]
      # remove
      set ustack [lrange $ustack 0 end-2]
      # store
      set varstack($varn) $result
      # increment
      incr ptr
    }
    # get value from variable
    if { $i == "@" } {
      # get variable name
      set varn [lindex $ustack end]
      # remove
      set ustack [lrange $ustack 0 end]
      # get variable
      set result $varstack($varn)
      # store
      set ustack "$ustack $result"
      # increment
      incr ptr
    }
    # variable handling
    if { [isvariable $i] == 1 } {
      # poke
      set ustack "$ustack $i"
      # increment
      incr ptr
    }
  }
}

# clear user stack
set wordnametbl ""
set wordstack("CODE") ""
set varnametbl ""
set varstack("aa") ""
set loopcnt 0
# open
set finx [open "ftxt.txt" "r"]
# loop
while { [gets $finx sbuf] >= 0 } {
  # interpret
  if { $sbuf == "" } {
    continue
  }
  # interpret
  interpret $sbuf
}
#
close $finx

　built-inの命令（FORTHではワード）を用意し、選択は
　if...else...then、繰返しはdo...loopだけにしました。

　built-inのワードは、以下。

+
-
*
/
%
.
inc
dec
dup
cr
drop
rot
swap
<<
>>
&
|
^
<
<=
>
>=
==
!=
swap
if
else
then
do
I
loop
:
;
max
min
var
!
@

　シェルに相当するコマンドインタプリタは
　次のシーケンスで動かしてみました。

バッファから１行取得
トークンに分割
トークンが数値なら、スタックに転送
トークンがユーザー定義ワードなら、展開してbuilt-inワードのシーケンスに変換
ユーザーのワード定義指定があれば、専用エリアにbuilt-inワードのシーケンスに変換
ワードを実行
１に戻る

　シェル相当のコマンドインタプリタは、プロシージャ
　「interpret」にまとめました。

　プロシージャ「interpret」内で利用するビルトイン
　ワードを実現するために、トークンはスタック操作の
　他に、do...loop、if...else...thenに使う文字列を
　含めました。

　トークンの判定で、スタックに数値を積みます。

　スタックを実現するデータ構造にはリストを採用しました。

　１行をリストで表現すると、トークンの判別が
　簡便にできました。

　Tcl/Tkでは、foreachを使うと、リストからトークンを
　抽出するのは簡単になります。

　ユーザー定義ワードは、連想配列の中にワード名と
　処理シーケンスをペアで格納します。

　イメージは、次のようになります。

"mul10" -> POKE 10 MUL
"mul3"  -> POKE 3 MUL
"mulx"  -> POKE 2 MUL POKE 1 ADD


　ユーザー定義ワードを使う場合、文字列を利用して
　該当するシーケンスに置換するので、マクロを使う
　イメージとなります。

　構文解析は、トークンスキャナーを定義し
　トークンを逐次調べて解釈します。
　ワードならば展開して、１行の内容を置換し
　次のトークンの調査に行きます。

　構文解析のプロシージャは、以下。

proc interpret {x} {
  global wordnametbl wordstack varnametbl varstack
  # copy
  set xx $x
  # show
  puts ">$xx"
  # clear
  set result ""
  set ustack ""
  # replace word
  set yy ""
  foreach i $xx {
    # copy
    set tmp $i
    # ? word
    if { [lsearch -exact $wordnametbl $i] >= 0 } {
      set tmp $wordstack($i)
    }
    # update
    set yy "$yy $tmp"
  }
  set xx $yy
  # initialize
  set last 0
  set xcnt 0
  # loop
  set len [llength $xx]
  set ptr 0
  while { $ptr < $len } {
    # get token
    set i [lindex $xx $ptr]
    # ?digit
    if { [string is digit -strict $i] == 1 } {
      # store digit
      set ustack "$ustack $i"
      # increment
      incr ptr
    }
    if { [string length $i] > 1 && [string index $i 0] == "-" } {
      # store digit
      set ustack "$ustack $i"
      # increment
      incr ptr
    }
    # + , - , * , /
    if { $i == "+" || $i == "-" || $i == "*" || $i == "/" || $i == "%" } {
      # calculate stack top
      set result [cmd_execute $i $ustack]
      # poke
      set ustack $result
      # increment
      incr ptr
    }
    # inc
    if { $i == "inc" || $i == "dec" } {
      # calculate stack top
      set result [cmd_execute $i [lindex $ustack end]]
      # remove stack top
      set ustack [lrange $ustack 0 end-1]
      # add stack top
      set ustack "$ustack $result"
      incr ptr
    }
    # dup
    if { $i == "dup" } {
      # get stack top
      set result [lindex $ustack end]
      # add stack top
      set ustack "$ustack $result"
      # increment
      incr ptr
    }
    # cr
    if { $i == "cr" } {
      # show empty list
      puts ""
      # increment
      incr ptr
    }
    # < , <= , > , >= 
    if { $i == "<" || $i == "<=" || $i == ">" || $i == ">=" } {
      #
      set ptrl [lsearch -exact $xx $i]
      # judge
      if { [llength $ustack] >= 2 } {
        # calculate
        set result [cmd_execute $i [lrange $ustack end-1 end]]
        # remove 2 digit
        set ustack [lrange $ustack 0 end-2]
        # add result
        set ustack "$ustack $result"
      }
      # increment
      set ptr [expr $ptrl+1]
    }
    # == , != 
    if { $i == "==" || $i == "!=" } {
      #
      set ptrl [lsearch -exact $xx $i]
      # judge
      if { [llength $ustack] >= 2 } {
        # calculate
        set result [cmd_execute $i [lrange $ustack end-1 end]]
        # remove 2 digit
        set ustack [lrange $ustack 0 end-2]
        # add result
        set ustack "$ustack $result"
      }
      # increment
      set ptr [expr $ptrl+1]
    }
    # drop
    if { $i == "drop" } {
      # remove stack top
      set ustack [lrange $ustack 0 end-1]
      # increment
      incr ptr
    }
    # rot
    if { $i == "rot" } {
      set result ""
      # judge
      if { [llength $ustack] >= 3 } {
        # get stack top
        set fx [lindex $ustack end]
        set ustack [lrange $ustack 0 end-1]
        # get stack top
        set sx [lindex $ustack end]
        set ustack [lrange $ustack 0 end-1]
        # get stack top
        set tx [lindex $ustack end]
        set ustack [lrange $ustack 0 end-1]
        # append
        set ustack "$ustack $fx $tx $sx"
      }
      # increment
      incr ptr
    }
    # << , >> 
    if { $i == "<<" || $i == ">>"} {
      # calculate
      set result [cmd_execute $i [lindex $ustack end]]
      # remove stack top
      set ustack [lrange $ustack 0 end-1]
      # append
      set ustack "$ustack $result"
      # increment
      incr ptr
    }
    # & , | , ^
    if { $i == "&" || $i == "|" || $i == "^" } {
      set result ""
      # judge
      if { [llength $ustack] >= 2 } {
        # get stack top
        set sx [lindex $ustack end]
        set ustack [lrange $ustack 0 end-1]
        # get stack top
        set fx [lindex $ustack end]
        set ustack [lrange $ustack 0 end-1]
        # calculate
        set tmp "$fx $sx"
        set result [cmd_execute $i $tmp]
        # append
        set ustack "$ustack $result"
      }
      # increment
      incr ptr
    }
    # if
    if { $i == "if" } {
      # get result
      set result [lindex $ustack end]
      # remove stack top
      set ustack [lindex $ustack end-1]
      # else location
      set ptrelse [lsearch -exact $xx "else"]
      # judge
      if { $result == 1 } {
        # increment
        incr ptr
      } else {
        # update
        if { $ptrelse >= 0 } {
          set ptr [expr $ptrelse+1]
        } else {
          set ptr [lsearch -exact $xx "then"]
        }
      }
    }
    # else
    if { $i == "else" } {
      # update
      set ptr [lsearch -exact $xx "then"]
    }
    # then
    if { $i == "then" } {
      # increment
      incr ptr
    }
    # do
    if { $i == "do" } {
      # judge
      if { [llength $ustack] >= 2 } {
        # get end count
        set last [lindex $ustack end-1]
        # get start count
        set xcnt [lindex $ustack end]
        # remove 2 digit
        set ustack [lrange $ustack 0 end-2]
      }
      # increment
      incr ptr
    }
    # I
    if { $i == "I" } {
      # poke I(xcnt)
      set ustack "$ustack $xcnt"
      # increment
      incr ptr
    }
    # loop
    if { $i == "loop" } {
      # increment control counter
      set xcnt [expr $xcnt+1]
      # judge
      if { $xcnt < $last } {
        set ptrdo [lsearch -exact $xx "do"]
        set ptr [expr $ptrdo+1]
      } else {
        # increment
        incr ptr
      }
    }
    # word definition :
    if { $i == ":" } {
      # word name
      set wdn [lindex $xx [expr $ptr+1]]
      # memory
      set wordnametbl "$wordnametbl $wdn"
      # word body
      set wdbody [lrange $xx [expr $ptr+2] end-1]
      # store
      set wordstack($wdn) $wdbody
      # 
      set ptr [lsearch -exact $xx ";"]
    }
    # word definition ;
    if { $i == ";" } {
      puts $wordnametbl
      # increment
      incr ptr
    }
    # max
    if { $i == "max" } {
      # get first datum
      set result [lindex $ustack 0]
      # loop
      foreach i $ustack {
        # compare
        if { $result < $i } {
          set result $i
        }
      }
      # update
      set ustack "$ustack $result"
      # increment
      incr ptr
    }
    # min
    if { $i == "min" } {
      # get first datum
      set result [lindex $ustack 0]
      # loop
      foreach i $ustack {
        # compare
        if { $result > $i } {
          set result $i
        }
      }
      # update
      set ustack "$ustack $result"
      # increment
      incr ptr
    }
    # var
    if { $i == "var" } {
      # get variable name
      set varn [lindex $xx [expr $ptr+1]]
      # store variable name
      set varnametbl "$varnametbl $varn"
      # set pseudo value
      set varstack($varn) 0
      # increment
      set ptr [expr $ptr+2]
    }
    # .
    if { $i == "." } {
      # get stack top
      set result [lindex $ustack end]
      # delete
      set ustack [lrange $ustack 0 end-1]
      # show
      puts $result
      # increment
      incr ptr
    }
    # set value to variable
    if { $i == "!" } {
      # get variable name
      set varn [lindex $ustack end]
      # get variable
      set result [lindex $ustack end-1]
      # remove
      set ustack [lrange $ustack 0 end-2]
      # store
      set varstack($varn) $result
      # increment
      incr ptr
    }
    # get value from variable
    if { $i == "@" } {
      # get variable name
      set varn [lindex $ustack end]
      # remove
      set ustack [lrange $ustack 0 end]
      # get variable
      set result $varstack($varn)
      # store
      set ustack "$ustack $result"
      # increment
      incr ptr
    }
    # variable handling
    if { [isvariable $i] == 1 } {
      # poke
      set ustack "$ustack $i"
      # increment
      incr ptr
    }
  }
}

　１行をリストとみなして、トークンに分割します。

　トークンがユーザーが定義したワードであるかを調べ
　もしユーザー定義ワードであれば、展開します。

　トークンの種別を判定し、数値であればスタックに
　積み、ワードなら対応する処理を実行します。

　四則演算のような単純な計算は、関数を定義して使います。

proc cmd_execute {xcmd x} {
  # get parameters
  set car [lindex $x 0]
  set cdr [lrange $x 1 end]
  # ADD
  if { $xcmd == "+" } {
    foreach i $cdr {
      set car [expr $car + $i]
    }
  }
  # SUBTRACT
  if { $xcmd == "-" } {
    foreach i $cdr {
      set car [expr $car - $i]
    }
  }
  # MULTIPLY
  if { $xcmd == "*" } {
    foreach i $cdr {
      set car [expr $car * $i]
    }
  }
  # DIVIDE
  if { $xcmd == "/" } {
    foreach i $cdr {
      if { $i != 0 } {
        set car [expr $car / $i]
      }
    }
  }
  # REMAINDER
  if { $xcmd == "%" } {
    foreach i $cdr {
      if { $i != 0 } {
        set car [expr $car % $i]
      }
    }
  }
  # INCREMENT
  if { $xcmd == "inc" } {
    set car [expr $car + 1]
  }
  # DECREMENT
  if { $xcmd == "dec" } {
    set car [expr $car - 1]
  }
  # LESS THAN
  if { $xcmd == "<" } {
    set cdr [lindex $cdr 0]
    if { $car < $cdr } {
      set car 1
    } else {
      set car 0
    }
  }
  # LESS THAN or EQUAL
  if { $xcmd == "<=" } {
    set cdr [lindex $cdr 0]
    if { $car <= $cdr } {
      set car 1
    } else {
      set car 0
    }
  }
  # GREATER THAN
  if { $xcmd == ">" } {
    set cdr [lindex $cdr 0]
    if { $car > $cdr } {
      set car 1
    } else {
      set car 0
    }
  }
  # GREATER THAN or EQUAL
  if { $xcmd == ">=" } {
    set cdr [lindex $cdr 0]
    if { $car >= $cdr } {
      set car 1
    } else {
      set car 0
    }
  }
  # EQUAL
  if { $xcmd == "==" } {
    set cdr [lindex $cdr 0]
    if { $car == $cdr } {
      set car 1
    } else {
      set car 0
    }
  }
  # NOT EQUAL
  if { $xcmd == "!=" } {
    set cdr [lindex $cdr 0]
    if { $car != $cdr } {
      set car 1
    } else {
      set car 0
    }
  }
  # &
  if { $xcmd == "&" } {
    set cdr [lindex $cdr 0]
    set car [expr $car & $cdr]
  }
  # |
  if { $xcmd == "|" } {
    set cdr [lindex $cdr 0]
    set car [expr $car | $cdr]
  }
  # ^
  if { $xcmd == "^" } {
    set cdr [lindex $cdr 0]
    set car [expr $car ^ $cdr]
  }
  # <<
  if { $xcmd == "<<" } {
    set car [expr $car * 2]
  }
  # >>
  if { $xcmd == ">>" } {
    set car [expr $car / 2]
  }

  return $car
}

　if...else...thenに関しては、スタックに保存した
　数値から１か０を生成します。１では、ifに連なる
　ブロックを実行、０では、elseに連なるブロックを
　実行します。

　do...loopでは、doの位置で初期値、終了値をスタック
　から取出します。初期値を内部カウンタに設定しておき
　loopの位置で、内部カウンタを更新。内部カウンタ値が
　終了値ならば終了します。内部カウンタが最終値未満で
　あれば、doの右に連なるブロックを実行。

　do...loopのdo、loopは、制御で必要になる初期化、判定
　制御変数更新のタイミングを指定するラベルと考えました。

　計算と比較処理は、シーケンスで利用する文字列さえ
　判断できれば、ひとつのブロックにまとめられますが
　可読性が悪くなるので、分割して記述しています。

　可読性を無視して、高速動作をとれば、シーケンスで
　利用する文字列を数値にします。後からワードを追加
　と考えると、数値では判読しにくいと思い、文字列に
　しています。

---

目次 前 次