# 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
# https://wiki.tcl-lang.org/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]]"
}
}