目次

インタプリタソースコード(Tcl/Tk)

 前ページまでの内容をまとめて、Tcl/TkのGUIで
 利用できるインタプリタソースコードは、以下。

#!/usr/bin/wish

. configure -width 320 -height 240

wm title . "My Basic"
wm resizable . 0 0

#######################################
# initialize variables
#######################################
set fd_in  ""
set fd_out ""
set fName  "unknown"

# initialize line number and statement
for {set i 0} {$i < 4096} {incr i} {
  set ls($i) -1
  set ss($i) ""
}

# make hash table (variable)
for {set i 0} {$i < 26} {incr i} {
  # generate ascii code
  set j [format "%c" [expr $i+65]]
  # substitute
  set xvar($j) 0
}

# make hash table (array)
for {set i 0} {$i < 101} {incr i} {
  # generate ascii code
  set j "\<$i\>"
  # substitue
  set xarray($j) 0
}

set bline 0
set currentLine 10
set currentResult ""
set rstack ""
set loc_while 0
set while_flag 0
set loc_for  0
set for_flag 0
set for_cc   ""
set forb -1
set fors -1
set forl -1
set fcnt -1
set io_in_v  "00000000"
set io_out_v "00000000"
set rflag 0

#######################################
# define labels objects
#######################################
label .lblCode          -text "Code"
label .lblFileName      -text "File Name"
label .lblBeginLine     -text "Begin Line"
label .lblCurrentLine   -textvariable currentLine
label .lblCurrentResult -textvariable currentResult
label .lblInputs        -text "Inputs"
label .lblOutputs       -text "Outputs"
label .lblOutputsV      -textvariable io_out_v

#######################################
# define listbox
#######################################
listbox .lsbCode -xscrollcommand ".sh set" -yscrollcommand ".sv set" -width 32

#######################################
# define scroll bar
#######################################
scrollbar .sv -orient vertical   -command ".lsbCode yview"
scrollbar .sh -orient horizontal -command ".lsbCode xview"

#######################################
# define entry
#######################################
entry .entFileName  -textvariable fName -bg green
entry .entBeginLine -textvariable bline
entry .entInputs    -textvariable io_in_v -width 8

#######################################
# define button objects
#######################################
button .btnLoad   -text "Load"   -command "fload"   -width 12 -bg #0000ff
button .btnSave   -text "Save"   -command "fsave"   -width 12 -bg #ff0000
button .btnRun    -text "Run"    -command "xrun"    -width 12 -bg green
button .btnStep   -text "Step"   -command "xstep"   -width 12
button .btnCancel -text "Cancel" -command "xcancel" -width 12 -bg yellow
button .btnExit   -text "Exit"   -command "exit"    -width 12 -bg #007f7f

############################
# define procedures
############################

proc fload {} {
  global fName fd_in ls ss currentLine
  # get file name
  set FName [tk_getOpenFile -filetypes {{"basic" {.bas .BAS}}}]
  # copy
  set fName [lindex [split $FName /] end]
  set fName [lindex [split $fName .] 0]
  # clear
  set i 0
  .lsbCode delete 0 end
  # open file
  set fd_in [open $FName "r"]
  # loop
  while { [gets $fd_in sbuf] >= 0 } {
    # toupper
    set sbuf [string toupper $sbuf 0 end]
    # store
    .lsbCode insert end $sbuf
    # store line number
    set ls($i) [lindex $sbuf 0]
    # store statement
    set ss($i) [lrange $sbuf 1 end]
    #tk_messageBox -message "$ls($i):$ss($i)" -type ok
    # increment
    incr i
  }
  # close
  close $fd_in
  # update
  set currentLine $ls(0)
}

proc fsave {} {
  # tk_messageBox -message "Save" -type ok
  global fName fd_out
  # get line number
  #set last [.]
}

proc xrun {} {
  #
  global rflag bline currentLine currentResult
  # initialize
  set bline 0
  set currentLine 10
  set currentResult ""
  # set
  set rflag 1
  # loop
  do_event
}

proc xstep {} {
  #
  global bline ls ss currentLine rstack loc_while while_flag
  global loc_for for_flag for_cc forb fors forl fcnt
  # get start line
  set pcx $bline
  # get line number and statement
  set xls $ls($pcx)
  set xss $ss($pcx)
  set currentLine $ls($pcx)
  set flag 0
  # get first command
  set fcmd [lindex $xss 0]
  # let
  if { $fcmd == "LET" } {
    set y [perform_let [lrange $xss 1 end]]
  }
  # if
  if { $fcmd == "IF" } {
    set y [perform_if $xss]
    if { $y != 0 } {
      set flag 1
      set xlnumber $y
    }
  }
  # while
  if { $fcmd == "WHILE" } {
    # condition
    set loc [lrange $xss 1 end]
    # get condition
    set xcond [get_condition_value $loc]
    # ? skip or goto next WEND 
    if { $xcond == 1 } {
      # set do flag
      set while_flag 1
      # store this location
      set loc_while $pcx
    } else {
      # clear flag
      set while_flag 0
      # next line number
      set xlnumber [expr [get_wend_loc $pcx] + 1]
      # change line number
      set flag 1
    }
  }
  # wend
  if { $fcmd == "WEND" } {
    # check
    if { $while_flag == 1 } {
      # clear flag
      set while_flag 0
      # next location
      set xlnumber $loc_while
      # change line number
      set flag 1
    }
  }
  # for
  if { $fcmd == "FOR" } {
    # ? first
    if { $for_flag == 0 } {
      # get token
      set y [is_fors $xss]
      # ? complete FOR statement
      if { [lindex $y 0] == 1 } {
        # change flag 
        set for_flag 1
        # store this location
        set loc_for $pcx
        # get control variable
        set for_cc [lindex $xss 1]
        # get first value
        set forb [lindex $xss 3]
        set fcnt $forb
        # get last value
        set forl [lindex $xss 5]
        # get step value
        if { [llength $xss] == 8 } {
          set fors [lindex $xss end]
        }
        # store value to target variable or array
        set yy [store_var_array "$for_cc $fcnt"]
      }
    }
  }
  # next
  if { $fcmd == "NEXT" } {
    # check
    if { $for_flag == 1 } {
      # update counter
      if { $fors != -1 } {
        set fcnt [expr $fcnt + $fors]
      } else {
        set fcnt [expr $fcnt + 1]
      }
      # store value to target variable or array
      set yy [store_var_array "$for_cc $fcnt"]
    }
    # judge
    if { $fcnt > $forl } {
      # clear flag
      set for_flag 0
      # initialize
      set for_cc ""
      set forb -1
      set fors -1
      set forl -1
      set fcnt -1
    } else {
      # next location
      set xlnumber $loc_for
      # change line number
      set flag 1
    }
  }
  # print / ?
  if { $fcmd == "PRINT" || $fcmd == "?" } {
    set y [perform_print [lrange $xss 1 end]]
  }
  # goto
  if { $fcmd == "GOTO" } {
    # get listbox index
    set xlnumber [get_listbox_index [lindex $xss 1]]
    # change next line number
    set flag 1
  }
  # gosub
  if { $fcmd == "GOSUB" } {
    # get listbox index
    set xlnumber [get_listbox_index [lindex $xss 1]]
    # store current line number
    set rstack "$rstack $pcx"
    # change next line number
    set flag 1
  }
  # return 
  if { $fcmd == "RETURN" } {
    # get line number from rstack
    set xlnumber [expr [lindex $rstack end]+1]
    # copy return stack list
    set xlen [llength $rstack]
    set xlen [expr $xlen - 1]
    set rr [lrange $rstack 0 $xlen]
    set rstack $rr
    # change next line number
    set flag 1
  }
  # OUT
  if { [string range $fcmd 0 3] == "OUTP" } {
    # get parameter
    set xout [string range $fcmd 5 end]
    # remove )
    set yout [string trimright $xout ")"]
    # store
    outp_handler $yout
  }
  # OUTP
  if { [string range $fcmd 0 3] == "OUT(" } {
    # get parameter
    set xout [string range $fcmd 4 end]
    # separate
    set xstr [split $xout ,]
    set xb [lindex $xstr 0]
    set xv [string trimright [lindex $xstr end] ")"]
    # store
    out_handler "$xb $xv"
  }
  # update line
  incr pcx
  if { $flag == 1 } {
    set pcx $xlnumber
  }
  set bline $pcx
  set currentLine $ls($pcx)
}

proc xcancel {} {
  #
  global rflag bline currentLine currentResult
  # clear
  set rflag 0
  # initialize
  set bline 0
  set currentLine 10
  set currentResult ""
}

proc get_value {x} {
  #
  global xvar xarray io_in_v io_out_v
  # default
  set result $x
  # have operator
  if { [have_operator $x] > 0 } {
    set result [calc_asmdr $x]
  }
  # variable
  if { [is_variable $x] > 0 } {
    set result $xvar($x)
  }
  # array
  if { [is_array $x] > 0 } {
    set result $xarray($x)
  }
  # INP
  if { [have_inp $x] > 0 } {
    set result [get_decimal $io_in_v]
  }
  # IN
  if { [have_in $x] > 0 } {
    set result [in_handler $x]
  }

  return $result
}

proc is_variable {x} {
  # default
  set result 0
  # judge
  for {set i 0} {$i < 26} {incr i} {
    # generate string
    set symbol [format "%c" [expr $i+65]]
    # compare
    if { $symbol == $x } {
      set result 1
    }
  }

  return $result
}

proc is_array {x} {
  # default
  set result 0
  # judge
  for {set i 0} {$i < 101} {incr i} {
    # generate string
    set symbol "\<$i\>"
    # compare
    if { $symbol == $x } {
      set result 1
    }
  }

  return $result
}

proc have_operator {x} {
  # default
  set result 0
  # copy
  set xx $x
  # judge
  if { [llength [split $xx +]] > 1 } {
    set result 1
  }
  if { [llength [split $xx -]] > 1 } {
    set result 1
  }
  if { [llength [split $xx *]] > 1 } {
    set result 1
  }
  if { [llength [split $xx /]] > 1 } {
    set result 1
  }
  if { [llength [split $xx %]] > 1 } {
    set result 1
  }
  if { [llength [split $xx &]] > 1 } {
    set result 1
  }
  if { [llength [split $xx |]] > 1 } {
    set result 1
  }
  if { [llength [split $xx ^]] > 1 } {
    set result 1
  }

  return $result
}

proc have_in {x} {
  #
  set result 0
  # judge
  if { [string range $x 0 2] == "IN(" } {
    set result 1
  }

  return $result
}

proc have_out {x} {
  #
  set result 0
  # judge
  if { [string range $x 0 3] == "OUT(" } {
    set result 1
  }

  return $result
}

proc have_inp {x} {
  #
  set result 0
  # judge
  if { $x == "INP()" } {
    set result 1
  }

  return $result
}

proc have_outp {x} {
  #
  set result 0
  # judge
  if { $x == "OUTP()" } {
    set result 1
  }

  return $result
}

proc get_calc_param {x} {
  # first
  set car [lindex $x 0]
  # second
  set cdr [lindex $x end]
  # convert
  set xcar [get_value $car]
  set xcdr [get_value $cdr]
  # concatenate
  set result "$xcar $xcdr"

  return $result
}

proc calc_asmdr {x} {
  # default
  set result $x
  # +(add)
  if { [llength [split $x +]] > 1 } {
    # split
    set xx [split $x +]
    # get parameters
    set y [get_calc_param $xx]
    # separate
    set xcar [lindex $y 0]
    set xcdr [lindex $y end]
    # add
    set result [expr $xcar + $xcdr]
  }
  # -(subtract)
  if { [llength [split $x -]] > 1 } {
    # split
    set xx [split $x -]
    # get parameters
    set y [get_calc_param $xx]
    # separate
    set xcar [lindex $y 0]
    set xcdr [lindex $y end]
    # subtract
    set result [expr $xcar - $xcdr]
  }
  # *(multiply)
  if { [llength [split $x *]] > 1 } {
    # split
    set xx [split $x *]
    # get parameters
    set y [get_calc_param $xx]
    # separate
    set xcar [lindex $y 0]
    set xcdr [lindex $y end]
    # multiply
    set result [expr $xcar * $xcdr]
  }
  # /(divide)
  if { [llength [split $x /]] > 1 } {
    # split
    set xx [split $x /]
    # get parameters
    set y [get_calc_param $xx]
    # separate
    set xcar [lindex $y 0]
    set xcdr [lindex $y end]
    # divide
    set result [expr $xcar / $xcdr]
  }
  # %(resident)
  if { [llength [split $x %]] > 1 } {
    # split
    set xx [split $x %]
    # get parameters
    set y [get_calc_param $xx]
    # separate
    set xcar [lindex $y 0]
    set xcdr [lindex $y end]
    # add
    set result [expr $xcar % $xcdr]
  }
  # &(logical and)
  if { [llength [split $x &]] > 1 } {
    # split
    set xx [split $x &]
    # get parameters
    set y [get_calc_param $xx]
    # separate
    set xcar [lindex $y 0]
    set xcdr [lindex $y end]
    # logical and
    set result [expr $xcar & $xcdr]
  }
  # |(logical or)
  if { [llength [split $x |]] > 1 } {
    # split
    set xx [split $x |]
    # get parameters
    set y [get_calc_param $xx]
    # separate
    set xcar [lindex $y 0]
    set xcdr [lindex $y end]
    # logical or
    set result [expr $xcar | $xcdr]
  }
  # ^(logical exclusive or)
  if { [llength [split $x ^]] > 1 } {
    # split
    set xx [split $x ^]
    # get parameters
    set y [get_calc_param $xx]
    # separate
    set xcar [lindex $y 0]
    set xcdr [lindex $y end]
    # logical exclusive or
    set result [expr $xcar ^ $xcdr]
  }

  return $result
}

proc get_array_idx {x} {
  # default
  set result "<101>"
  #
  set xx [split $x {}]
  set yy [llength $xx]
  # one
  if { $yy == 3 } {
    set result [lindex $xx 1]
  }
  # two
  if { $yy == 4 } {
    set result "[lindex $xx 1][lindex $xx 2]"
  }
  # three
  if { $yy == 5 } {
    set result "[lindex $xx 1][lindex $xx 2][lindex $xx 3]"
  }

  return $result
}

proc get_listbox_index {x} {
  #
  global ls
  # search
  set result -1
  for {set i 0} {$i < 4096} {incr i} {
    if { $ls($i) == $x } {
      set result $i
    }
  }

  return $result
}

proc perform_let {x} {
  #
  global xvar xarray currentResult
  # separate
  set xx [split $x ,]
  # 
  set es ":="
  # array multiplex
  if { [llength $xx] > 2 } {
    # get value array
    set va [lrange $xx 1 end]
    # get index
    set xt [get_array_idx [lindex $xx 0]]
    # loop
    set stmp ""
    set i $xt
    foreach e $va {
      # get value
      set vx [get_value $e]
      # generate symbol
      set gsymbol "\<$i\>"
      # store
      set xarray($gsymbol) $vx
      set stmp "$stmp $gsymbol$es$xarray($gsymbol)"
      # update
      incr i
    }
    # show
    set currentResult $stmp
  } else {
    # get target
    set xt [lindex $xx 0]
    # get expression
    set xv [get_value [lindex $xx end]]
    # target array
    if { [is_array $xt] > 0 } {
      set xarray($xt) $xv
      # show
      set currentResult $xt$es$xarray($xt)
    }
    # target variable
    if { [is_variable $xt] > 0 } {
      set xvar($xt) $xv
      # show
      set currentResult $xt$es$xvar($xt)
    }
    # target INP
    if { [have_inp $xt] > 0 } {
      set currentResult "$xt$es[inp_handler]"
    }
    # target IN
    if { [have_in $xt] > 0 } {
      set currentResult "$xt$es[in_handler $xt]"
    }
  }

  return 0
}

proc perform_if_handler {x} {
  # default
  set result 0
  # get command
  set xcmd [lindex $x 0]
  # LET
  if { $xcmd == "LET" } {
    perform_let $x
  }
  # PRINT
  if { $xcmd == "?" || $xcmd == "PRINT" } {
    perform_print $x
  }
  # GOTO
  if { $xcmd == "GOTO" } {
    # get listbox index
    set xl [get_listbox_index [lindex $x 1]]
    # change line number
    set result $xl
  }
  # GOSUB
  if { $xcmd == "GOSUB" } {
    tk_messageBox -message "-<GOSUB>-" -type ok
    # get listbox index
    set xl [get_listbox_index [lindex $tstatement 1]]
    # change line number
    set result $xl
  }

  return $result
}

proc perform_if {x} {
  # check
  set y [is_ifs $x]
  # default
  set xcond      ""
  set tstatement ""
  set estatement ""
  set flag 0
  # 
  if { [lindex $y 0] != -1 } {
    # condition
    set loc [lrange $y 1 2]
    # get condition
    set xcond [get_condition $x $loc]
    # then & else close
    if { [lindex $y 3] != -1 } {
      set loc [lrange $y 2 3]
      set ts [get_statement $x $loc]
      # else close
      set loc [lrange $y 3 end]
      set es [get_statement $x $loc]
    } else {
      set loc "[lindex $y 2] [lindex $y end]"
      set ts [get_statement $x $loc]
    }
    # get condition value
    set dflag [get_condition_value $xcond]
    # do then statement
    if { $dflag == 1 } {
      set xl [perform_if_handler $ts]
      if { $xl != 0 } {
        set flag 1
      }
    } else {
      # do else statement
      if { $estatement != "" } {
        set xl [perform_if_handler $es]
        if { $xl != 0 } {
          set flag 1
        }
      }
    }
  }
  # default
  set result 0
  # GOTO or GOSUB
  if { $flag == 1 } {
    set result $xl
  }

  return $result
}

proc perform_print {x} {
  #
  global xvar xarray currentResult io_in_v
  # separate
  set xx [split $x ,]
  # loop
  set stmp ""
  set fs ":"
  foreach e $xx {
    # default
    set result ""
    # ? variable
    if { [is_variable $e] > 0 } {
      set result "$e$fs$xvar($e)"
    }
    # ? array
    if { [is_array $e] > 0 } {
      set result "$e$fs$xarray($e)"
    }
    # ? INP
    if { [have_inp $e] > 0 } {
      set result "$e$fs[inp_handler]"
    }
    # ? IN
    if { [have_in $e] > 0 } {
      set result "$e$fs[in_handler $e]"
    }
    # ? expression
    if { [have_operator $e] > 0 } {
      set result "$e$fs[calc_asmdr $e]"
    }
    # concatenate
    set stmp "$stmp $result"
  }
  # show
  set currentResult $stmp

  return 0
}

proc is_ifs {x} {
  # copy
  set xx $x
  # initialize flag
  set bflag -1
  set fflag -1
  set tflag -1
  set eflag -1
  # initialize location
  set bl -1
  set fl -1
  set tl -1
  set el -1
  # loop
  set i 0
  foreach e $xx {
    # judge
    if { $e == "IF" } {
      set bflag 1
      set bl $i
    }
    if { $e == "ENDIF" } {
      set fflag 1
      set fl $i
    }
    if { $e == "THEN" } {
      set tflag 1
      set tl $i
    }
    if { $e == "ELSE" } {
      set eflag 1
      set el $i
    }
    # increment
    incr i
  }
  # ? correct IF statement
  set result [expr $bflag * $tflag * $fflag]

  return "$result $bl $tl $el $fl"
}

proc is_fors {x} {
  # copy
  set xx $x
  # initialize flag
  set bflag -1
  set tflag -1
  set eflag -1
  # initialize location
  set bl -1
  set tl -1
  set el -1
  # loop
  set i 0
  foreach e $xx {
    # judge
    if { $e == "FOR" } {
      set bflag 1
      set bl $i
    }
    if { $e == "TO" } {
      set tflag 1
      set tl $i
    }
    if { $e == "STEP" } {
      set eflag 1
      set el $i
    }
    # increment
    incr i
  }
  # ? correct FOR statement
  if { $bflag == 1 && $tflag == 1 } {
    set result 1
  }

  return "$result $bl $tl $el"
}

proc get_condition {x y} {
  # copy
  set xx $x
  # start
  set bl [lindex $y 0]
  # exit
  set fl [lindex $y end]
  # split
  set stmp [lrange $x [expr $bl + 1] [expr $fl - 1]]

  return $stmp
}

proc get_statement {x y} {
  # copy
  set xx $x
  # start
  set bl [lindex $y 0]
  # exit
  set fl [lindex $y end]
  # split
  set stmp [lrange $x [expr $bl + 1] [expr $fl - 1]]

  return $stmp
}

proc get_condition_value {x} {
  # default
  set result 0
  # 
  set first  [lindex $x 0]
  set xop    [lindex $x 1]
  set second [lindex $x end]
  # judge
  if { $xop == "=" } {
    set car [get_value $first]
    set cdr [get_value $second]
    if { $car == $cdr } {
      set result 1
    }
  }
  if { $xop == "<>" } {
    set car [get_value $first]
    set cdr [get_value $second]
    if { $car != $cdr } {
      set result 1
    }
  }
  if { $xop == ">=" } {
    set car [get_value $first]
    set cdr [get_value $second]
    if { $car >= $cdr } {
      set result 1
    }
  }
  if { $xop == ">" } {
    set car [get_value $first]
    set cdr [get_value $second]
    if { $car > $cdr } {
      set result 1
    }
  }
  if { $xop == "<=" } {
    set car [get_value $first]
    set cdr [get_value $second]
    if { $car <= $cdr } {
      set result 1
    }
  }
  if { $xop == "<" } {
    set car [get_value $first]
    set cdr [get_value $second]
    if { $car < $cdr } {
      set result 1
    }
  }

  return $result
}

proc get_wend_loc {x} {
  global ss
  # default
  set result 0
  # search
  for {set i [expr $x+1]} {$i < 4096} {incr i} {
    # get statement
    set xstmp $ss($i)
    # ? start with WEND
    if { [lindex $xstmp 0] == "WEND" } {
      set result $i
    }
  }

  return $result
}

proc store_var_array {x} {
  global xvar xarray
  # get variable name
  set vname [lindex $x 0]
  # get value
  set vv [lindex $x 1]
  # store value to variable
  if { [is_variable $vname] == 1 } {
    set xvar($vname) $vv
  }
  # store value to array
  if { [is_array $vname] == 1 } {
    set xarray($vname) $vv
  }

  return 0
}

proc in_handler {x} {
  #
  global io_in_v
  # get index
  set xx [string index $x 3]
  # judge
  if { $xx == "<" } {
    if { [string index $x 5] == ">" } {
      set xv [get_value [string range $x 3 5]]
    } else {
      if { [string index $x 6] == ">" } {
        set xv [get_value [string range $x 3 6]]
      } else {
        set xv [get_value [string range $x 3 7]]
      }
    }
  } else {
    set xv [get_value [string index $x 3]]
  }
  # copy
  set result [string index $io_in_v [expr 7-$xv]]

  return $result
}

proc inp_handler {} {
  #
  global io_in_v

  return [get_decimal $io_in_v]
}

proc out_handler {x} {
  #
  global io_out_v
  # get bit location
  set bx [get_value [lindex $x 0]]
  set bx [expr 7-$bx]
  # get bit value
  set bv [get_value [lindex $x end]]
  # 
  set result ""
  for {set i 0} {$i < 8} {incr i} {
    # get target bit
    set bb [string index $io_out_v $i]
    # replace
    if { $i == $bx } {
      set bb $bv
    }
    # append
    set result "$result$bb"
  }
  # store
  set io_out_v $result
}

proc outp_handler {x} {
  #
  global io_out_v
  # copy
  set xx $x
  # judge binary
  if { [string index $xx 0] == "\'" } {
    set y [get_decimal [string range $xx 1 8]]
    set ud [dec2bin [expr $y / 16]]
    set ld [dec2bin [expr $y % 16]]
    set yy "$ud$ld"
  }
  # judge hexadecimal
  if { [string index $xx 0] == "#" } {
    set ud [hex2bin [string index $xx 1]]
    set ld [hex2bin [string index $xx 2]]
    set yy "$ud$ld"
  }
  # judge variable
  if { [is_variable $x] > 0 } {
    set y [get_value $x]
    set ud [dec2bin [expr $y / 16]]
    set ld [dec2bin [expr $y % 16]]
    set yy "$ud$ld"
  }
  # judge array
  if { [is_array $x] > 0 } {
    set y [get_value $x]
    set ud [dec2bin [expr $y / 16]]
    set ld [dec2bin [expr $y % 16]]
    set yy "$ud$ld"
  }
  # store
  set io_out_v $yy
}

proc get_decimal {x} {
  # copy
  set xx $x
  # clear
  set result 0
  # add
  for {set i 0} {$i < 8} {incr i} {
    # get target 
    set tmp [string index $xx $i]
    # add
    set result "[expr $result * 2 + $tmp]"
  }

  return $result
}

proc dec2bin {x} {
  # default
  set result "0000"
  # judge
  if { $x == 1 } {
    set result "0001"
  }
  if { $x == 2 } {
    set result "0010"
  }
  if { $x == 3 } {
    set result "0011"
  }
  if { $x == 4 } {
    set result "0100"
  }
  if { $x == 5 } {
    set result "0101"
  }
  if { $x == 6 } {
    set result "0110"
  }
  if { $x == 7 } {
    set result "0111"
  }
  if { $x == 8 } {
    set result "1000"
  }
  if { $x == 9 } {
    set result "1001"
  }
  if { $x == 10 } {
    set result "1010"
  }
  if { $x == 11 } {
    set result "1011"
  }
  if { $x == 12 } {
    set result "1100"
  }
  if { $x == 13 } {
    set result "1101"
  }
  if { $x == 14 } {
    set result "1110"
  }
  if { $x == 15 } {
    set result "1111"
  }

  return $result
}

proc hex2bin {x} {
  # default
  set result "0000"
  # judge
  if { $x < 10 } {
    set result [dec2bin $x]
  }
  if { $x == "A" || $x == "a" } {
    set result "1010"
  }
  if { $x == "B" || $x == "b" } {
    set result "1011"
  }
  if { $x == "C" || $x == "c" } {
    set result "1100"
  }
  if { $x == "D" || $x == "d" } {
    set result "1101"
  }
  if { $x == "E" || $x == "e" } {
    set result "1110"
  }
  if { $x == "F" || $x == "f" } {
    set result "1111"
  }

  return $result
}

proc do_event {} {
  #
  global rflag
  # handling
  if { $rflag == 1 } {
    xstep
  }
  after 1000 do_event
}

############################
# place objects
############################
grid .lblFileName -column 1 -row 0
grid .lblCode     -column 0 -row 2

grid .lblInputs  -column 3 -row 4
grid .entInputs  -column 4 -row 4

grid .lblOutputs  -column 3 -row 6
grid .lblOutputsV -column 4 -row 6

grid .lsbCode -column 1 -row 2
grid .sv      -column 2 -row 2 -sticky ns
grid .sh      -column 1 -row 3 -sticky ew

grid .lblBeginLine     -column 1 -row 4
grid .entBeginLine     -column 1 -row 5
grid .lblCurrentLine   -column 1 -row 6
grid .lblCurrentResult -column 1 -row 7

grid .entFileName -column 1 -row 1

grid .btnLoad   -column 4 -row 0
grid .btnSave   -column 4 -row 1
grid .btnRun    -column 0 -row 4
grid .btnStep   -column 0 -row 5
grid .btnCancel -column 0 -row 6
grid .btnExit   -column 4 -row 9

 GUIで、BASICのテキストファイルをロード(LOAD)してから
 「RUN」ボタンで動かすか、1行ごとに「STEP」ボタンで実行。

 「RUN」ボタンでプログラムを動かしたとき、止めるのは
 「CANCEL」ボタンを使います。

 テキストファイルとしての保存には、セーブ(SAVE)ボタンを
 用意していますが、今のところは、同一プログラムの別名で
 の保存としています。

 別名保存を活用し、プログラムの機能を拡張できます。


目次

inserted by FC2 system