Version 0 of let

Updated 2002-08-09 22:56:57

# let.tcl # Copyright 2001 by Larry Smith # Wild Open Source, Inc # For license terms see "COPYING" # # let is a replacement for the "set" command. It allows # multiple assignment, and supports a variety of assignment # operators: # # let a b c = 1 ;# this sets a b and c to 1 # let a b c = 1 + 4 ;# "=" uses expr to process the value to assign # let a b c += 1 ;# computed assignments are allowed, +-*/&| supported # let a b c := info commands ;# uses eval to process value # let a b c @= 1 2 3;# "hoisting" assignment, foreach replacement # let a b c @:= info commands;# uses eval and hoists for assignment # let a ++ ;# incr and # let a -- ;# decr are supported.

proc let { args } {

  if { [llength $args ] == 2 } {
    if [string equal [ lindex $args 1 ] "++" ] {
      set result [ uplevel incr [ lindex $args 0 ] ]
    } elseif [string equal [ lindex $args 1 ] "--" ] {
      set result [ uplevel incr [ lindex $args 0 ] -1 ]
    } else {
      set result [ uplevel set "$args" ]
    }
  } else {
    regexp {([^=:+\-*/&|@]*)([:+\-*/&|@]?)([@]*)=(.*)} $args -> vars op optional rest
    if ![ info exists op ] {
      return -code error -errorcode 1 "no valid assignment operator in $args"
    }
    switch -- $op {
      : {
        if [llength [info commands [lindex $rest 0]]] {
          set result [uplevel $rest]
        } else {
          set result $rest                ;# this should always work...
        }
        if { "$optional" == "@" } {
          set max [ llength $result ]
          foreach var $vars res $result {
            uplevel 1 [ list set $var $res ]
          }
        } else {
          foreach var $vars {
            set result [ uplevel set $var \"$result\" ]
          }
        }
      }
      @ {
        if { "$optional" == ":" } {
          set rest [uplevel $rest]
        }
        set max [ llength $rest ]
        if { $max == 1 } {
          eval set rest $rest
          set max [ llength $rest ]
        }
        foreach var $vars res $rest {
          set result [ uplevel 1 [ list set $var $res ]]
        }
      }
      + - - - * - / - & - | {
        foreach var $vars {
          set result [ uplevel set $var \[ expr \$$var $op ( $rest ) \] ]
        }
      }
      = -
      default {
        if { [ catch { set result [ uplevel expr $rest ] } ] } {
          set result $rest              ;# this should always work...
        }
        foreach var $vars {
          set result [ uplevel set $var \"$result\" ]
        }
      }
    }
  }
  return $result

}