Importing expr functions, part 2

 # exprlib.tcl --
 #
 #       explode the functionality of [expr] into prefix-style procs.
 #
 #       e.g. from: set x [expr {42*14}]
 #            to:   set x [* 42 14]
 #
 # author: Glenn Jackman
 #         http://www.purl.org/net/glennj/
 #
 # references
 #       http://groups.google.com/groups?threadm=19b0c689.0107082126.67e6cf9a%40posting.google.com
 #       http://wiki.tcl.tk/expr
 #
 # Performance penalty: Using this library incurs significant penalties for
 # mathematically significant applications.  Consider:
 #
 #       % time {set pi [expr {atan(1)*4}]} 10000
 #       16 microseconds per iteration
 #       % package require exprlib; namespace import ::exprlib::*
 #       % time {set pi [* [atan 1] 4]} 10000
 #       267 microseconds per iteration

 package provide exprlib 0.1
 package require Tcl 8.0

 namespace eval ::exprlib {
     # unary and binary operators
     namespace export ! ~ + - * / % << >> < > <= >= == != eq ne & ^ | && ||

     # additional english operators
     namespace export and or not

     # math functions available since tcl 8.0
     namespace export abs double int round srand

     # functions added in tcl 8.4
     if {$::tcl_version >= 8.4} {
         namespace export wide
     }
     # functions added in tcl 8.3
     if {$::tcl_version >= 8.3} {
         namespace export acos asin atan atan2 ceil cos cosh exp
         namespace export floor fmod hypot log log10 pow sin sinh
         namespace export sqrt tan tanh
     }

     # rand has been augmented to accept lower and upper bounds
     namespace export rand

     # assignment operators
     namespace export += -= *= /= %= &= |= ^= <<= >>= &&= ||=
 }

 # unary operators
 #       !       logical not
 #       ~       bitwise not
 foreach op {! ~} {
     proc ::exprlib::$op arg "expr { $op \$arg }"
 }

 # "stretch" these binary operators
 #       +       add, also unary plus
 #       *       multiply
 #       &&      logical and
 #       ||      logical or
 foreach op {+ * && ||} {
     proc ::exprlib::$op args "expr \[join \$args $op]"
 }

 # - is special because it can be unary or binary
 #       -       subtract, unary minus
 proc ::exprlib::- {arg1 {arg2 ""}} {
     expr { ($arg2 eq "") ? (- $arg1) : ($arg1 - $arg2) }
 }

 # true binary operators
 #       /       divide
 #       %       remainder
 #       <<      left shift
 #       >>      right shift
 #       <       boolean less than
 #       >       boolean greater than
 #       <=      boolean less than or equal to
 #       >=      boolean greater than or equal to
 #       ==      boolean equal
 #       !=      boolean not equal
 #       eq      string equal
 #       ne      string not equal
 #       &       bitwise and
 #       ^       bitwise xor
 #       |       bitwise or
 foreach op {/ % << >> < > <= >= == != & ^ |} {
     proc ::exprlib::$op {arg1 arg2} "expr { \$arg1 $op \$arg2 }"
 }

 if {$::tcl_version >= 8.4} {
     foreach op {eq ne} {
         proc ::exprlib::$op {arg1 arg2} "expr { \$arg1 $op \$arg2 }"
     }
 } else {
     proc ::exprlib::eq {arg1 arg2} {
         expr {[string compare $arg1 $arg2] == 0}
     }
     proc ::exprlib::ne {arg1 arg2} {
         expr {[string compare $arg1 $arg2] != 0}
     }
 }

 # english operators
 #       and     logical and
 #       or      logical or
 #       not     logical not
 foreach {srcCmd targetCmd} {&& and || or ! not} {
     proc ::exprlib::$targetCmd args "eval ::exprlib::$srcCmd \$args"
 }

 ################################################################################
 # math functions
 #
 # with tcl 8.4 we can introspect the math functions with [info functions]
 # but that does not tell us the number of arguments each takes.  We'd be
 # exposed to vague error messages "too many/few arguments for math function"

 foreach func { abs double int round srand } {
     proc ::exprlib::$func arg "expr { ${func}(\$arg) }"
 }
 if {$::tcl_version >= 8.4} {
     proc ::exprlib::wide arg {expr { wide($arg) }}
 }
 if {$::tcl_version >= 8.3} {
     foreach func { acos asin atan ceil cos cosh exp floor
                    log log10 sin sinh sqrt tan tanh } {
         proc ::exprlib::$func arg "expr { ${func}(\$arg) }"
     }
     foreach func { atan2 fmod hypot pow } {
         proc ::exprlib::$func {arg1 arg2} "expr { ${func}(\$arg1,\$arg2) }"
     }
 }

 # return a pseudo-random number in the range [lowerBound, upperBound)
 proc ::exprlib::rand {{lowerBound 0} {upperBound 1}} {
     expr { (rand() * ($upperBound - $lowerBound)) + $lowerBound }
 }

 ################################################################################
 # assignment operators

 #       ++      autoincrement
 proc ::exprlib::++ varname {
     upvar 1 $varname var
     if {[info exists var]} {incr var} {set var 1}
 }

 #       --      autodecrement
 proc ::exprlib::-- varname {
     upvar 1 $varname var
     if {[info exists var]} {incr var -1} {set var -1}
 }

 #       +=      add
 proc ::exprlib::+= {varname value} {
     upvar 1 $varname var
     if {[info exists var]} {incr var $value} {set var $value}
 }

 #       -=      subtract
 proc ::exprlib::-= {varname value} {
     upvar 1 $varname var
     if {[info exists var]} {incr var [- $value]} {set var [- $value]}
 }

 #       *=      multiply
 #       /=      divide
 #       %=      modulus
 #       <<=     left shift
 #       >>=     right shift
 #       &=      bitwise and
 #       |=      bitwise or
 #       ^=      bitwise xor
 foreach op {*= /= %= <<= >>= &= |= ^=} {
     proc ::exprlib::$op {varname value} "
         upvar 1 \$varname var
         set var \[[string range $op 0 [expr {[string length $op]-2}]] \$var \$value]
     "
 }

 # the perl &&= and ||= operators
 #       &&=     assign to var if the current value of var is true
 #       ||=     assign to var if the current value of var is false or unset
 # (These may be somewhat less useful in Tcl, as Perl has a different
 # notion of truth values.)
 proc ::exprlib::&&= {varname value} {
     upvar 1 $varname var
     if {[info exists var]} {
         if {$var} {set var $value} {set var}
     }
     # return nothing if var is unset?
 }
 proc ::exprlib::||= {varname value} {
     upvar 1 $varname var
     if {[info exists var] && $var} {set var} {set var $value}
 }

 ################################################################################
 proc ::exprlib::_introspect {} {
     foreach p [lsort [info procs [namespace current]::*]] {
         puts "proc $p [list [info args $p]] [list [info body $p]]"
     }
 }
Category Package