# 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]]"
}
}