Version 8 of Smalltick

Updated 2004-05-27 21:54:32 by GPS

Smalltalk like object system in pure-Tcl.

Author: GPS

Smalltick is not a typical Tcl object system. It uses instance inheritance, so you aren't limited by the definition of a class. You can add new methods dynamically easily. It does not use namespaces to store methods and variables, but it also doesn't prevent you from using them. Instance variables are stored in a private array, and each method uses a unique-command-name prefix, so collisions are not a problem.

Classes in Smalltick are just procs with commands that associate variables and methods with an object.

 $ tclsh8.4
 % source ./Smalltick.tcl
 % set obj [new.object]
 cmd-2108840903
 % $obj set {var value}
 value
 % $obj get var
 value
 % $obj : foo {} { puts FOO }
 cmd-2108840903->foo
 % $obj foo
 FOO
 % $obj : bar arg { $self set [list var $arg] }
 cmd-2108840903->bar
 % $obj bar 123
 123
 % $obj get var
 123

You may notice that the instance variable setting is a little weird. This is due to the generic application of method invocation. For instance $obj -foo arg -bar arg is generalized to treat the argument to the method as a single list. If you want to pass multiple arguments define a method like so:

 $obj : mul {a b} {expr {$a + $b}} 

and then use it in this manner:

 $obj mul [list 1 2]

Redistribution/Licensing: OLL

 #Copyright 2004 George Peter Staplin

 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] \
    [lindex $args 2] \
    "set self $obj; [lindex $args 3]"
   return $obj->[lindex $args 1]
  } else {
   set r ""
   foreach {msg arg} $args {
    switch -- [llength $arg] {
     0 {
      set r [$obj->[set msg]]
     }
     1 {
      set r [$obj->[set msg] [lindex $arg 0]]
     }
     2 {
      set r [$obj->[set msg] [lindex $arg 0] [lindex $arg 1]]
     } 
     3 {
      set r [$obj->[set msg] [lindex $arg 0] [lindex $arg 1] [lindex $arg 2]]
     }
     4 {
      set r [$obj->[set msg] [lindex $arg 0] [lindex $arg 1] [lindex $arg 2] [lindex $arg 3]]
     }
     5 {
      set r [$obj->[set msg] [lindex $arg 0] [lindex $arg 1] [lindex $arg 2] [lindex $arg 3] [lindex $arg 4]]
     }
    }
   }
   return $r
  }
 }

 proc new.object {} {
  set obj [get.unique.command.name]
  interp alias {} $obj {} instance.handler $obj

  $obj : ?set {var value} {
   if {![info exists ::_priv_instances($self,$var)]} {
    return -code error "expected $var to exist in $self"
   }
   set ::_priv_instances($self,$var) $value
  }
  $obj : decr var {
   incr ::_priv_instances($self,$var) -1
  }
  $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 : incr var {
   incr ::_priv_instances($self,$var)
  }
  $obj : set {var value} {
   set ::_priv_instances($self,$var) $value
  }
  return $obj
 }

Category Object Orientation | Category Package