[Smalltalk] like object system in pure-Tcl

----
 #Copyright 2004 George Peter Staplin
 #Smalltick - A Smalltalk-like object system in pure-Tcl.
 #Version 1.3
 
 set ::expand_arguments {
  if {[llength $_priv_arg_list] != [llength $args]} {
   return -code error "invalid number of arguments"
  }
  foreach _priv_var $_priv_arg_list _priv_val $args {
   set $_priv_var $_priv_val
  }
 }
 
 proc get.unique.command.name {} {
  while 1 {
   if {"" == [info commands [set n cmd[clock clicks]]]} {
    return $n
   }
  }
 }
 
 proc instance.handler {obj args} {
  if {":" == [lindex $args 0]} {
   proc $obj->[lindex $args 1] \
    [list args [list _priv_arg_list [lindex $args 2]]] \
    "set self $obj
     $::expand_arguments
     [lindex $args 3]"
   return
  } else {
   foreach {msg arg} $args {
    set r [[set obj]->[set msg] $arg]   
   }
   return $r
  }
 }
 
 proc new.object {} {
  set obj [get.unique.command.name]
  interp alias {} $obj {} instance.handler $obj
  $obj : destroy {} {
   foreach cmd [info commands [set self]*] {
    rename $cmd {}
   } 
   array unset ::_priv_instances [set self],*
  }
  $obj : get var {
   return [set ::_priv_instances($self,$var)]
  }
  $obj : set {var value} {
   set ::_priv_instances($self,$var) $value
  }
  return $obj
 }
 
 ############## Example Code ################
 proc Ball self {
  $self set [list pressure 0]
 
  $self : -bounce n {
   puts "Bouncing $n times."
   $self do.a.bounce.until.0 $n
  }
 
  $self : -dance {} {
   puts "$self says shake your groove thing!"
  }
 
  $self : -inflate p {
   puts "Inflating from [$self get pressure] to $p lbs. of pressure."
   $self set [list pressure $p]
   $self do.inflate [list 0 $p]
  }
 
  $self : -roll d {
   puts "Rolling $d degress."
  }
 
  $self : do.a.bounce.until.0 n {
   if {$n <= 0} return
   puts "Bouncy! $n"
   after 100
   $self do.a.bounce.until.0 [incr n -1]
  }
 
  $self : do.inflate {i n} {
   if {$i > $n} return
   puts "PSI $i"
   after 50
   $self do.inflate [list [incr i] $n]
  }
 
  return $self
 }
 
 proc Balloon self {
  $self set [list color bland]
  $self : -set.color col {
   puts "Changing [set self]'s color from [$self get color] to $col"
   $self set [list color $col]
  }
  $self : -set.location {x y z} {
   puts "x:$x y:$y z:$z"  
   $self set [list x $x] set [list y $y] set [list z $z]
  }
  return $self
 }
 
 proc main {} {
  set b [Ball [new.object]]
  $b -roll 32 -inflate 20 -bounce 10 -dance 
  $b destroy
  set bal [Balloon [new.object]]
  $bal -set.color [list [list wild indigo]] -set.location [list 5 7 9]
  $bal destroy
 }
 main
----
[Category Object Orientation]