Updated 2011-08-09 09:41:09 by RLE

I've always been a big fan of HP calcs, but of all the simulated ones none really try to equal the best of the "traditional" (pre-rpl) models - the 32SII and the 42S. This one doesn't either, at least not yet, but it has potential. The basic plumbing is there, one just needs to fill in a lot of functions - and I've not been able to get to that, so I hope some of you will. Many of the functions are already laid out, if you get a "no such func: XXX" message, all you need to is to add the function by that name. The existing funcs should show how to access the internals. If you don't see a function you'd like to add, use one of the "( )" placeholders to insert it. If you can't find a placeholder in the f, finv, g, or h shifts, the green "spare" shift is entirely free right now, and could be eliminated when the calc is done if no one comes up with anything needing that shift.

Hopefully the use of the calc should be fairly obvious. There are 1000 registers, however only 20 can be addressed directly, 0-9 and .0-.9, which correspond to 10-19. The rest can be addressed indirectly. One feature awaiting implementation is the ability to reset reg_base, which defaults to 0, and alt_base, which defaults to 10. This will allow you to shift the 0-9 and .0-.9 register "windows" around in the 1000 register space. Flags work in a similar manner.

The design, by the way, is meant to be realizable in actual hardware. That is, the shift keys are meant to be separate colors on an old-fashioned HP-style keypad - f and finv (yellow) to the upper left (only f shown, finv implied - notice that finv is always the exact opposite of the equivalent f function), g (blue) to the upper right, unshifted top, h (black) on the front, and spare (green) below left. Alpha would be white and below right. The top row of keys, whose legends change in menus and the like, are presumed to actually be labelled with the LCD screen above.

You can start the calc with -size {tiny | small | medium | large} to allow for failing eyes or conserving screen real estate.

Someday, when this is finished, it would make a wonderful addition to the Palm Pilot. Or even be built (Hey, I can dream, can't I?)

MB 2008-11-20 : Thank you for that calculator ! I did some updates so that it can be used on a PDA.
    #http://wiki.tcl.tk/10854
    # DKF
    #
    # rpncalc.tcl --
    #   A Programmable RPN Calculator
    # Usage :
    #   rpncalc.tcl key value ...
    # Arguments
    #   -size size : the size of the calculator : tiny, small, medium or large or PDA
    #      Default size is "small" or PDA for Windows CE system.
    # History
    #   2008-11-20, MB : small updates to make it usable on PDAs under Windows CE.
    #
    package require Tk
    proc init { arglist } {
      set rest {}
      foreach { var val } $arglist {
        set var [ string range $var 1 end ]
        uplevel 1 set $var \{$val\}
        lappend varlist $var
      }
      return ""
    }

    switch -- $::tcl_platform(os) {
      "Windows CE" {
        set size "PDA"
      }
      default {
        set size "small"
      }
    }
    init $::argv

    set stdmenu "1/X X! % %ch ABS \u03c0"
    set xstack 0
    set SIGMODE 0
    set numbase DEC
    set anglemode DEG

    label .dummy -text "xxx"
    set dummyfont [.dummy cget -font]
    destroy .dummy
    array set attributes [font actual $dummyfont]
    switch $size {
      PDA   {
        #wm geometry . 240x360
        set attributes(-size)  8
        set attributes(-family)  "Tahoma"
        set attributes(-weight)  normal
        set minsize 20
        set iw 6
      }
      tiny   {
        set attributes(-size)  5
        set attributes(-weight) bold
        set minsize 20
        set iw 6
      }
      small  {
        set attributes(-size)  8;
        set attributes(-weight) bold
        set minsize 80
        set iw 12
      }
      medium {
        set attributes(-size) 12;
        set attributes(-weight) bold
        set minsize 110
        set iw 12
      }
      large  {
        set attributes(-size) 18;
        set attributes(-weight) bold
        set minsize 130
        set iw 12
      }
      default {
        error "Unknown size $size"
      }
    }

    set font [eval font create [array get attributes]]
    option add *font $font
    option add *background gray
    option add *activebackground gray
    option add *highlightbackground gray
    option add *highlightcolor gray

    label .tl -text "DEC" -anchor w -background lightgray -width $iw
    label .tn -text "T:"  -anchor e -background lightgray
    label .tt -background lightgray -foreground black -anchor w -relief sunken

    label .zl -text "DEG" -anchor w -background lightgray -width $iw
    label .zn -text "Z:"  -anchor e -background lightgray
    label .zt -background lightgray -foreground black -anchor w -relief sunken

    label .yl -text "4STK" -anchor w -background lightgray -width $iw
    label .yn -text "Y:"   -anchor e -background lightgray
    label .yt -background lightgray -foreground black -anchor w -relief sunken

    label .xl -text "\u03a3LIN" -anchor w -background lightgray -width $iw
    label .xn -text "X:"  -anchor e -background lightgray
    label .xt -background lightgray -foreground black -anchor w -relief sunken

    grid config .tl -row 0 -column 0 -sticky "nsw"
    grid config .tn -row 0 -column 0 -sticky "nse"
    grid config .tt -row 0 -column 1 -columnspan 5 -sticky "nsew"
    grid config .zl -row 1 -column 0 -sticky "nsw"
    grid config .zn -row 1 -column 0 -sticky "nse"
    grid config .zt -row 1 -column 1 -columnspan 5 -sticky "nsew"
    grid config .yl -row 2 -column 0 -sticky "nsw"
    grid config .yn -row 2 -column 0 -sticky "nse"
    grid config .yt -row 2 -column 1 -columnspan 5 -sticky "nsew"
    grid config .xl -row 3 -column 0 -sticky "nsw"
    grid config .xn -row 3 -column 0 -sticky "nse"
    grid config .xt -row 3 -column 1 -columnspan 5 -sticky "nsew"

    set udklist { udk1 udk2 udk3 udk4 udk5 udk6 }

    set shiftlist { func invf g h spare alpha }

    set label(func)   f
    set label(invf)   f\u00af\u00b9
    set label(g)      g
    set label(h)      h
    set label(spare)  spare
    set label(alpha)  \u03b1

    set bg(func)      yellow
    set bg(invf)      yellow
    set bg(g)         slateblue
    set bg(h)         black
    set bg(spare)     darkgreen
    set bg(alpha)     white
    set bg(unshifted) black

    set fg(func)      black
    set fg(invf)      black
    set fg(g)         white
    set fg(h)         white
    set fg(spare)     white
    set fg(alpha)     black
    set fg(unshifted) black

    set funcname(\u03c0)   const-pi
    set funcname(\u2190)   backsp
    set funcname(.)   decimal

    set btnlist {
      0  1  2  3  4  5  \
        6  7  8  9  10 11 \
        12 13 14 15 16 17 \
        18 19 20 21 22 23 \
        24 25 26 27 28 29
    }

    set unshifted {
      "PRINT"  "X\u2194Y" "CHS"  "EEX"  "\u2190" "\u00f7"  \
        "7"      "8"        "9"    "0xA"  "0xD"    "\u00d7"  \
        "4"      "5"        "6"    "0xB"  "0xE"    "-"       \
        "1"      "2"        "3"    "0xC"  "0xF"    "+"       \
        "ON/OFF" "0"        "."    "DO"   "MOD"    "ENTER"
    }

    set func {
      "(    )" "INT"      "D\u2192H" "R\u2192P" "D\u2192R" "\u03a3+"     \
        "STO"    "X\u00b2"  "Y\u2191X" "LN"       "LOG"      "(    )"      \
        "ST0@"   "(    )"   "(    )"   "(    )"   "ISG"      "R\u2191"     \
        "FS?"    "M\u2192E" "(    )"   "(    )"   "(    )"   "\u03a3ALL"   \
        "EXIT"   "XSTK+"    "SF#"      "(    )"   "SST"      "(    )"
    }

    set invf {
      "(    )" "FRAC"     "D\u2190H" "R\u2190P" "D\u2190R"    "\u03a3-"  \
        "RCL"    "\u221aX"  "Y\u221aX" "e\u2191X" "10\u2191X"   "(    )"   \
        "RCL@"   "(    )"   "(    )"   "(    )"   "DSZ"         "R\u2193"  \
        "FC?"    "M\u2190E" "(    )"   "(    )"   "(    )"      "\u03a3LIN"\
        "EXIT"   "XSTK-"    "CF#"      "(    )"   "BST"         "(    )"
    }

    set g {
      "HYP"     "PROG"   "TEST"     "IF"     "GTO"    "SHL" \
        "TRIG"    "LBL"    "DISP"     "LOOP"   "GSB"    "SHR" \
        "BASE"    "DRG"    "P\u2194S" "(    )" "RTN"    "AND" \
        "CLEAR"   "STDM"   "(    )"   "(    )" "NOT"    "XOR" \
        "EXIT"    "RND#"   "2'sC"     "(    )" "LstX"   "OR"
    }

    set h {
      "SOLVE"  ""       "SD"       "PSD"     "AVG"   "\u222bf(x)" \
        "L.R."   "AVGxy"  "s,\u03c3" "SUMS"    "CFIT"  "NPV"   \
        "N"      "Int"    "PMT"      "PV"      "FV"    "DATE-" \
        "IRR"    "BOND"   "DEPR"     "BAL"     "%T"    "DATE+" \
        "EXIT"   "(    )" "(    )"   "(    )"  "ACCi"  "ENTER"
    }

    set spare {
      "(    )" "(    )" "(    )" "(    )" "(    )" "(    )" \
        "(    )" "(    )" "(    )" "(    )" "(    )" "(    )" \
        "(    )" "(    )" "(    )" "(    )" "(    )" "(    )" \
        "(    )" "(    )" "(    )" "(    )" "(    )" "(    )" \
        "(    )" "(    )" "(    )" "(    )" "(    )" "(    )"
    }

    set alpha {
      "A"    "B"   "C"   "D"    "E"    "F" \
        "G"    "H"   "I"   "J"    "K"    "L" \
        "M"    "N"   "O"   "P"    "Q"    "R" \
        "S"    "T"   "U"   "V"    "W"    "X" \
        "EXIT" "Y"   "Z"   "punc" "cap"  "ENTER"
    }

    set lock 0
    set curshift ""
    proc setlabels { newshift } {
      global btnlist func invf alpha g h unshifted spare lock curshift bg

      if [ string equal $newshift $curshift ] {
        set lock [ expr !$lock ]
        if $lock return
        setlabels unshifted
        return
      }
      set curshift $newshift
      set lock 0
      set n 0
      foreach btn $btnlist {
        set text [ lindex [ set $newshift ] $n ]
        set fg $bg($curshift)
        .$btn configure -text $text -foreground $fg -activeforeground $fg
        incr n
      }
    }

    proc call { func } {
      global funcname
      if [ info exists funcname($func) ] {
        set func $funcname($func)
      }
      if [string match $func [ info commands $func ]] {
        if ![string equal $func ""] $func
      } else {
        puts "no such func: $func"
      }
    }

    proc dispatch { key } {
      global lock curshift shiftlist menupick

      if [ regexp udk(.) $key mpos ] {
        if $menupick {
          set temp [ .$key cget -text ]
          if [ string equal $temp "" ] return
          if [ string equal $temp >> ] { next
        } elseif [ string equal $temp << ] { prev
      } else { set menupick $temp
      }
      return
    }
    set function [ .$key cget -text ]
    call $function
    return
    }
    if { $menupick } {
      if { $key != 24 } return
      set menupick ""
    }
    if { [ lsearch -exact $shiftlist $key ] != -1 } {
      setlabels $key
      return
    }
    global $curshift
    set function [ lindex [set $curshift] $key ]
    if ![ string equal $function "" ] {
      if [ string equal $curshift alpha ] {

        puts "function: $function"

        if { [ string length $function ] > 1 } {
          call $function
        } else {

          puts "inpchar $function"

        }
      } else {
        call $function
      }
    }
    if !$lock { setlabels unshifted }
    }

    set curmenu ""
    set oldmenu ""
    set menubase 0
    set menupick 0

    proc updudks { } {
      global menubase curmenu

      set i $menubase
      set menulen [ llength $curmenu ]
      for { set j 1 } { $j <= 6 } { incr j } {
        if { $j > $menulen } {
          .udk$j configure -text ""
        } else {
          .udk$j configure -text [ lindex $curmenu [ expr $menubase + $j -1 ]]
        }
      }
    }

    proc menu { args } {
      global curmenu oldmenu menubase stdmenu

      if [string equal $args ""] { set args $stdmenu }
      set oldmenu $curmenu
      set curmenu $args
      set menubase 0
      set page 6
      while { [ llength $curmenu ] > $page } {
        set curmenu [ linsert $curmenu [ expr $page - 1] >> << ]
        incr page 6
      }
      updudks
    }

    proc resume { } {
      global curmenu oldmenu menubase
      set curmenu $oldmenu
      set oldmenu ""
      set menubase 0
      updudks
    }

    proc pick { args } {
      global menupick oldmenu

      set menupick 1
      eval menu $args
      vwait menupick
      set result $menupick
      set menupick 0
      resume
      return $result
    }

    proc next { } {
      global menubase
      incr menubase 6
      updudks
    }

    proc prev { } {
      global menubase
      incr menubase -6
      updudks
    }

    set row 4 ; set col 0
    set keylist "$udklist $shiftlist $btnlist"
    foreach fn $keylist {
      set lbl $fn
      if [ info exists label($fn) ] { set lbl $label($fn) }
      set color ""
      if [ info exists fg($fn) ] {
        set color " -foreground $fg($fn) -background $bg($fn) "
        set color "$color -activeforeground $fg($fn) -activebackground $bg($fn) "
      } else {
        set color "-foreground black -activeforeground black"
      }
      if [ info exists label($fn) ] {
        set lbl $label($fn)
      }
      eval button .$fn $color -text $lbl -pady 0 -borderwidth 1
      .$fn configure -command [ list dispatch $fn ]
      grid config .$fn -row $row -column $col -sticky "nsew"
      incr col
      if { $col > 5 } {
        set col 0
        incr row
      }
    }

    wm protocol . WM_DELETE_WINDOW {OFF}

    set hyptrig 0
    set invtrig 1
    proc TRIG {} {
      global invtrig hyptrig
      set hyptrig 0
      if $invtrig {
        menu INV SIN COS TAN
      } else {
        menu INV ASIN ACOS ATAN
      }
    }
    proc HYP {} {
      global invtrig hyptrig
      set hyptrig 1
      if $invtrig {
        menu INV SINH COSH TANH
      } else {
        menu INV ASINH ACOSH ATANH
      }
    }
    proc INV {} {
      global invtrig hyptrig
      set invtrig [ expr !$invtrig ]
      if $hyptrig then HYP else TRIG
    }
    proc SUMS {} {
      global SIGMODE
      if { ${SIGMODE} } {
        set which [ pick n X Y X² Y² XY \
                     "lnX" "(lnX)²" "lnY" "(lnY)²" \
                     "(lnX)(lnY)" "X×lnY" "Y×lnX" ]
        # [DKF]: Not sure if the last two were fixed correctly...
      } else {
        set which [ pick n X Y X² Y² XY ]
      }
      puts "SUMS: $which"
    }
    proc punc {} {
      set ch [ pick ? , : \; ! ( ) \[ \] \{ \} spc _ * \" ' @ # $ % ^ & * = ~ ]
      puts "selected '$ch'"
    }
    proc BASE {} {
      set base [ pick HEX DEC OCT BIN ]
      .tl configure -text "$base"
      puts "new base: $base"
    }
    proc DISP {} {
      set disp [ pick ALL FIX SCI ENG ]
      puts "disp is: $disp"
    }
    proc EXIT {} { setlabels unshifted }
    proc DRG {} {
      global anglemode
      set anglemode [ pick DEG RAD GRD ]
      .zl configure -text "$anglemode"
    }
    proc CLEAR {} {
      global x y z t
      set what [ pick REGS \u03a3REG FIN PROG STACK X ALL ]
      if [ string equal $what ALL ] {
        set sure [ pick "DO IT" EXIT ]
        if [ string equal $sure "DO IT" ] {
          puts "clearing all"
        }
      } else {
        switch $what {
          REGS {}
          \u03a3REG {}
          FIN  {}
          PROG {}
          STACK { set x 0 ; set y 0; set z 0; set t 0; end }
          X { set x 0; end }
        }
        puts "clearing $what"
      }
    }
    proc XSTK+ {} {
      global xstack
      set xstack 1
      .yl configure -text "XSTK"
    }
    proc XSTK- {} {
      global xstack
      set xstack 0
      .yl configure -text "4STK"
    }
    proc \u03a3ALL {} {
      global SIGMODE
      set SIGMODE 1
      .xl configure -text "\u03a3ALL"
    }
    proc \u03a3LIN {} {
      global SIGMODE
      set SIGMODE 0
      .xl configure -text "\u03a3LIN"
    }
    proc L.R. {} {
      set which [ pick ESTx ESTy r m b ]
      puts "Linear Regression: $which"
    }
    proc AVGxy {} {
      set which [ pick AVGx AVGy AVGxw ]
      puts "AVGxy: $which"
    }
    proc s,\u03c3 {} {
      set which [ pick sx sy \u03c3x \u03c3y ]
      puts "s,\u03c3: $which"
    }
    proc CFIT {} {
      set which [ pick MODL ... ]
      puts "CFIT: $which"
    }
    proc BOND {} {
      set which [ pick PRICE YTM ]
      puts "BOND: $which"
    }
    proc DEPR {} {
      set which [ pick SL SOYD DB ]
      puts "DEPRECIATION: $which"
    }
    proc STDM {} {
      menu
    }
    proc TEST {} {
      set which [ pick X?0 X?Y FS? FC? FS?C FC?S ]
      set func ""
      switch $which {
        X?0 { set func [ pick < \u2264 = \u2260 \u2265 > ] }
        X?Y { set func [ pick < \u2264 = \u2260 \u2265 > ] }
      }
      if [ string equal $func "" ] {
        puts "test: $which"
      } else {
        set which [ string replace $which 1 1 $func ]
        puts "test: $which"
      }
    }
    proc IF {} {
      set which [ pick TEST ELSE ELSIF ENDIF ]
      if [ string equal $which "TEST" ] TEST
      puts "IF $which"
    }
    proc LOOP {} {
      set which [ pick BEGIN BREAK NEXT ENDL ]
      puts "LOOP: $which"
    }
    proc M\u2192E {} {
      set which [ pick in ft yds miles degF gals lbs ]
    }
    proc E\u2192M {} {
      set which [ pick cm m km degC ltrs kgs ]
    }
    proc ON/OFF {} {
      exit
    }
    proc OFF {} {
      exit
    }
    proc ON {} {
      set which [ pick OFF EXIT ]
      if [ string equal $which OFF ] OFF
    }

    setlabels unshifted
    menu

    grid columnconfigure . 0 -minsize $minsize
    grid columnconfigure . 1 -minsize $minsize
    grid columnconfigure . 2 -minsize $minsize
    grid columnconfigure . 3 -minsize $minsize
    grid columnconfigure . 4 -minsize $minsize
    grid columnconfigure . 5 -minsize $minsize
    wm title . "HP-43"

    set x 0
    set y 0
    set z 0
    set t 0

    proc upddisp {} {
      global x y z t
      .tt configure -text $t
      .zt configure -text $z
      .yt configure -text $y
      .xt configure -text $x
    }

    proc pull {} {
      global needpush x y z t
      set x $y
      set y $z
      set z $t
      set needpush 1
    }

    proc ENTER {} {
      global needpush wipex x y z t
      set t $z
      set z $y
      set y $x
      set wipex 1
      set needpush 0
      upddisp
    }

    set needpush 1
    set wipex 0
    proc key n {
      global needpush wipex x y z t rcl_pending sto_pending
      puts "key: $n rp:$rcl_pending sp:$sto_pending"
      if { $rcl_pending || $sto_pending } {
        register $n
        return
      }
      if $needpush ENTER
      if { $wipex } {
        set x ""
        set wipex 0
      }
      if [ string equal $x "0" ] {
        set x $n
      } else {
        set x "${x}$n"
      }
      upddisp
    }

    proc backsp {} {
      global x needpush
      if $needpush {
        pull
      } else {
        set len [ expr [ string length $x ] - 2 ]
        set x [ string range $x 0 $len ]
        if [ string equal $x "" ] {
          pull
          set needpush 1
        }
      }
      upddisp
    }

    proc 0 {} { key 0 }
    proc 1 {} { key 1 }
    proc 2 {} { key 2 }
    proc 3 {} { key 3 }
    proc 4 {} { key 4 }
    proc 5 {} { key 5 }
    proc 6 {} { key 6 }
    proc 7 {} { key 7 }
    proc 8 {} { key 8 }
    proc 9 {} { key 9 }
    proc decimal {} { key . }

    proc float { args } {
      foreach var $args {
        upvar 1 $var tmp
        if [ string is integer $tmp ] {
          set tmp [ expr double($tmp) ]
        }
      }
    }

    proc end {} {
      global needpush
      set needpush 1
      upddisp
    }

    proc binop { op { real 0 } } {
      global x y needpush
      if $real { float x y }
      set result [ expr $y $op $x ]
      pull
      set x $result
      end
    }

    proc + {} { binop + }
    proc - {} { binop - }
    proc \u00d7 {} { binop * }
    proc \u00f7 {} { binop / 1 }
    proc X\u2194Y {} {
      global x y needpush
      set tmp $x
      set x $y
      set y $tmp
      end
    }
    proc 1/X {} {
      global x

      set x [ expr 1.0 / double($x) ]
      end
    }
    proc ABS {} {
      global x

      set x [ expr abs($x) ]
      end
    }
    proc const-pi {} {
      global x needpush
      if $needpush ENTER
      set x "3.141592653589792"
      end
    }

    proc gamma { c } {
      set cof(0)  76.18009172947146
      set cof(1) -86.50532032941677
      set cof(2)  24.01409824083091
      set cof(3)  -1.231739572450155
      set cof(4)   0.1208650973866179e-2
      set cof(5)  -0.5395239384953e-5
      set xx [ expr double($c) ]
      set yy [ expr double($c) ]
      set tmp [ expr $xx + 5.5 - ($xx + 0.5) * log($xx + 5.5) ]
      set ser 1.000000000190015
      for {set j 0 } { $j<=5 } { incr j } {
        set yy [ expr $yy + 1.0 ]
        set ser [ expr $ser + ($cof($j) / $yy) ]
      }
      return [ expr exp(log(2.5066282746310005*$ser/$xx)-$tmp) ]
    }

    proc X! {} {
      global x
      set result 1
      set j 0
      if [ string is integer $x ] {
        if { $x > 29 } {
          float result x j
        }
        for { set j 2 } { $j <= $x } { incr j } {
          set result [ expr { $result * $j } ]
        }
      } else {
        set result [ gamma [ expr double($x) + 1.0 ] ]
      }
      set x $result
      end
    }
    proc PRINT {} {
      global x y z t
      set what [ pick X Y Z T STK ]
      switch $what {
        X { puts "X = $x" }
        Y { puts "Y = $y" }
        Z { puts "Z = $z" }
        T { puts "T = $t" }
        STK { foreach reg { t z y x } {
        puts "[ string toupper $reg ] = [set $reg]" }
      }
    }
    }
    proc trig { func } {
      global anglemode x
      switch $anglemode {
        DEG { set x [ expr ${func}($x*3.141592653489792/180.0) ] }
        RAD { set x [ expr ${func}($x) ] }
        GRD { set x [ expr ${func}($x*3.141592653489792/200.0) ] }
      }
      end
    }
    proc atrig { func } {
      global anglemode x
      switch $anglemode {
        DEG { set x [ expr a${func}($x)/3.141592653489792*180.0 ] }
        RAD { set x [ expr a${func}($x) ] }
        GRD { set x [ expr a${func}($x)/3.141592653489792/200.0 ] }
      }
      end
    }
    proc htrig { func } {
      global anglemode x
      switch $anglemode {
        DEG { set x [ expr ${func}h($x*3.141592653489792/180.0) ] }
        RAD { set x [ expr ${func}h($x) ] }
        GRD { set x [ expr ${func}h($x*3.141592653489792/200.0) ] }
      }
      end
    }
    proc setglob { name value } { global $name ; set $name $value }
    proc SIN {}  { trig sin }
    proc COS {}  { trig cos }
    proc TAN {}  { trig tan }
    proc ASIN {} { atrig sin }
    proc ACOS {} { atrig cos }
    proc ATAN {} { atrig tan }
    proc SINH {} { htrig sin }
    proc COSH {} { htrig cos }
    proc TANH {} { htrig tan }
    proc STO {}  { puts "sto"; setglob sto_pending 1 }
    proc STO@ {} { setglob sto_pending 1 ; setglob indirect 1 }
    proc RCL {}  { setglob rcl_pending 1 }
    proc RCL@ {} { setglob rcl_pending 1 ; setglob indirect 1 }

    set reg_base 0
    set alt_base 10
    proc register { digit } {
      puts "register $digit"
      global alt_reg reg_base alt_base sto_pending rcl_pending x
      if [ string equal $digit "." ] {
        set alt_reg 1
        return
      }
      if $alt_reg {
        set regnum [ expr $digit + $alt_base ]
        set alt_base 0
      } else {
        set regnum [ expr $digit + $reg_base ]
      }
      global reg$regnum
      if $sto_pending {
        set reg$regnum $x
      } else {
        ENTER
        set x [ set reg$regnum ]
      }
      set sto_pending 0
      set rcl_pending 0
      end
    }
    # init regs
    for { set j 0 } { $j < 1000 } { incr j } {
      set reg$j 0
    }
    set alt_reg 0
    set sto_pending 0
    set rcl_pending 0
    set indirect 0
    set tcl_precision 17
    upddisp
    wm resizable . 0 0
    vwait forever

Here's a Mac OS X screenshot:

Larry Smith Looks nice in Aqua. But why don't the shift key colors show properly?

jcw - I'm not sure Aqua supports colors (buttons tend to be gray, plus a blue default). Or maybe Tk Aqua has no hooks for this yet.

Larry Smith Bummer. Sure wrecks a useful feature. Can you change the font color?

See also A little calculator - RPN