# 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.4 namespace eval ::exprlib { # unary and binary operators namespace export ! ~ + - * / % << >> < > <= >= == != eq ne & ^ | && || # math functions namespace export abs acos asin atan atan2 ceil cos cosh double exp namespace export floor fmod hypot int log log10 pow round sin sinh namespace export sqrt srand tan tanh wide # 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 {/ % << >> < > <= >= == != eq ne & ^ |} { proc ::exprlib::$op {arg1 arg2} "expr { \$arg1 $op \$arg2 }" } # 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 proc ::exprlib::rand {{lowerBound 0} {upperBound 1}} { expr { (rand() * ($upperBound - $lowerBound)) + $lowerBound } } # functions that take one argument foreach func { abs acos asin atan ceil cos cosh double exp floor int log log10 round sin sinh sqrt srand tan tanh wide } { proc ::exprlib::$func arg "expr { ${func}(\$arg) }" } # functions that take two arguments foreach func { atan2 fmod hypot pow } { proc ::exprlib::$func {arg1 arg2} "expr { ${func}(\$arg1,\$arg2) }" } ################################################################################ # 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 end-1] \$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]]" } } ---- [expr], [Category Package], [Glenn Jackman]