Yet another object system in Tcl  edit

Code  edit

Original

# optional: fast C-coded version of ihash, built with CriTcl
# package require ihash

# Tcl version, get or set items in a "key value key value ..." list
proc ihash {vref cmd args} {
  upvar $vref v
  lassign $args a b
  switch $cmd {
    get {
      foreach {x y} $v {
        if {$x == $a} {
          return $y
        }
      }
    }
    set {
      set i 1
      foreach {x y} $v {
        if {$x == $a} {
          if {$b != ""} {
            lset v $i $b
          } else {
            set v [lreplace $v [expr {$i-1}] $i]
          }
          return $b
        }
        incr i 2
      }
      if {$b != ""} {
        lappend v $a $b
      }
      return $b
    }
    default { error "$cmd: not implemented" }
  }
}

# all objects must be accessed as "! varname method args"
proc ! {self method args} {
  upvar $self me
  lassign [ihash me get $method] params body
  if {$body == ""} {
    if {[llength $args] == 0} {
      return $params
    }
    set a [lindex $args 0]
    ihash me set $method $a
    return $a
  }
  foreach 1 $params 2 $args {
    if {$1 == "args"} {
      set args [lrange $args [expr {[llength $params]-1}] end]
      break
    }
    set $1 $2
  }
  eval $body
}

Modernized

Fully compatible

proc ! {self method args} {
  upvar $self me
  lassign [dict get $me $method] params body
  if {$body eq ""} {
    # Get value.
    if {[llength $args] == 0} {
      return $params
    }
    # Set value.
    lassign $args a
    dict set me $method $a
    return $a
  }
  # Evaluate method.
  foreach 1 $params 2 $args {
    if {$1 eq "args"} {
      set args [lrange $args [expr {[llength $params]-1}] end]
      break
    }
    set $1 $2
  }
  eval $body
}

Modified

• An argument does not default to an empty string; arguments without an explicit default are required;
• Argument names that consist of several Tcl words (have whitespace) need extra quotes;
• It is an error to give useless extra arguments after the new value of a property;
• The variables self, method, params, and body are not defined when the body of the method is evaluated.

proc ! {self method args} {
    upvar $self me
    lassign [dict get $me $method] params body
    if {$body eq ""} {
        # Get value.
        if {[llength $args] == 0} {
            return $params
        } elseif {[llength $args] >= 2} {
            error {too many arguments}
        }
        # Set value.
        lassign $args a
        dict set me $method $a
        return $a
    }
    # Evaluate method.
    set preamble [list upvar $self me]
    uplevel 1 [list apply [list $params $preamble\n$body] {*}$args]
}

Examples  edit

Property

set obj1 {color red size 10 type apple}
puts [! obj1 color]

Method

set obj2 {factor 10 times {{x} { expr {$x * [! me factor]} }}}
! obj2 factor 2
puts [! obj2 times 123]

A more complex object

# a more readable example: raw definition of an "object" called "two"
set two {
  value 2
  times {{x} {
    return [expr {$x*2}]
  }}
  combine {{k args} {
    set v {}
    foreach x $args {
      lappend v [list $k $x]
    }
    return $v
  }}
}

# property access
puts [! two value]

# property setting
puts [! two value 3]

# member call
puts [! two times 5]

# member call with variable args
puts [! two combine 1 a b c]

# dump the full "object" again
puts $two

Counter

set counter {
  i 0
  incr {n {
    if {$n eq ""} { set n 1 }
    ! me i [expr {[! me i] + $n}]
  }}
}
puts [! counter incr] ;# 1
puts [! counter incr] ;# 2
set copy $counter
puts [! counter incr 98] ;# 100
puts [! copy incr] ;# 3

Gotcha

set obj {
  hello Hello!
  greet {{} {
    puts [! me hello]
  }}
}
! obj greet ;# Hello!

set obj {
  hello {Hello, World!}
  greet {{} {
    puts [! me hello]
  }}
}
catch { ! obj greet } err
puts $err ;# invalid command name "World!"

# correct
set obj {
  hello {{Hello, World!}}
  greet {{} {
    puts [! me hello]
  }}
}
! obj greet ;# Hello, World!

Benchmark  edit

Code

source yao.tcl

proc benchmark-counter-field {counterStart max} {
    set counter $counterStart
    for {set i 0} {$i < $max} {incr i} {
        ! counter i [expr {[! counter i] + 1}]
    }
}

proc benchmark-counter-method {counterStart max} {
    set counter $counterStart
    for {set i 0} {$i < $max} {incr i} {
        ! counter incr
    }
}

proc run {{max 10000} {times 5}} {
    set counterStart {
        i 0
        incr {{{n 1}} {
            ! me i [expr { [! me i] + $n }]
        }}
    }

    puts "Counting up to $max $times times."
    puts -nonewline { counter field:  }
    puts [time {benchmark-counter-field $counterStart $max} $times]
    puts -nonewline {counter method:  }
    puts [time {benchmark-counter-method $counterStart $max} $times]
}

run {*}$argv

Results

Counting up to 10000 5 times.
 counter field:  48657.8 microseconds per iteration
counter method:  293073.6 microseconds per iteration

See also  edit

• Classy YAO
• CritLib for ihash (obsolete)
• TOOT, a similarly transparent object system

Discussion  edit

 proc yao {name value} {
    if [llength [info commands $name]] {
        error "cannot override command $name"
    }
    uplevel 1 [set $name $value]     ;# creating "yet another object"
    interp alias {} $name {} ! $name ;# shorthand for calling it
    uplevel 1 [list trace var $name u "interp alias {} $name {} ;#"]
 }

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References