From a news:comp.lang.tcl posting by [Larry Smith] on 2000-08-21:

Richard Suchenwirth's articles on his "[gadgets]" system have
lead me to first reverse-engineer his basic idea, and then
to play with it for a bit.  This is the latest version of
it, and I'm calling mine '''LOST''', for ''Lightweight Object System
for Tcl''.  It's a rather intriguing demonstration of Tcl's
chameleon-like ability to adapt to a problem, in this case
using a meta-programming scheme...

See also [MOST] for a version using arrays which can be teamed
with [tequila] to provide remote object method calls for
simple but effective distributed programming.

The example code is based on Richard's example - the "="
method for File does not adapt well to the args parser I've
added (which parses the args for you and assigns useful local
variables).  But I left it that way since it's a demo based
on Richard's gadget idea and not a "production" system.  It's
lightly tested, I'm sure there are more bugs.  There is at
least one design difficiency, there is no way to call a super-
class's version of a method you've overridden.

To Richard's gadgets, this version adds multiple inheritance
and the ability to declare instance variables.

======
 # scans for -foo "str" pairs and converts them
 # into variable=value pairs in the surrounding
 # scope - i.e.  -foo "str" becomes "foo" with a
 # value of "str" in the calling routine.
 proc init { args } {
  set max [ llength $args ]
  if { $max == 1 } {
    # braced set of args
    eval set args $args
    set max [ llength $args ]
  }
  for { set i 0 } { $i <= $max } { } {
    set s [ lindex $args $i ]
    if { [ string index $s 0 ] == "-" } {
      set var [ string range $s 1 end ]
      incr i
      if { $i < $max } {
        set val [ lindex $args $i ]
        if { [ string index $val 0 ] != "-" } {
          uplevel 1 set $var \{$val\}
          continue
        }
      }
      uplevel 1 set $var 1
    }
    incr i
  }
 }

 proc class { type inherits instvars methods } {
  global classinfo

  foreach superclass $inherits {
    set methods "
      $methods
      $classinfo($superclass-methods)
    "
    eval lappend instvars $classinfo($superclass-instvars)
  }
  set classinfo($type-instvars) $instvars
  set classinfo($type-methods) $methods
  set typeproc {
    set instproc {
      upvar @var THIS
      @type THIS $method $args
    }
    upvar $var THIS
    if { "$method" == "" } { return $self(=value) }
    @init
    switch $method {
      @methods
    }
    regsub -all @var $instproc $var instproc
    proc $var { { method "" } args } $instproc
  }
  regsub -all @type $typeproc $type typeproc
  regsub -all self $methods THIS(=value) methods
  foreach instvar $instvars {
    if { "$instvar" == "args" } {
      regsub @init $typeproc {init $args} typeproc
    } else {
      regsub -all $instvar $methods self($instvar) methods
    }
  }
  regsub -all @init $typeproc "" typeproc
  regsub -all @methods $typeproc $methods typeproc
  regsub -all THIS $typeproc self typeproc
  proc $type { var method args } $typeproc
 }

 class File {} { args filename } {
  =     {set filename "$open" ; set self [open $open]}
  gets  {return [ gets $self ]}
  puts  {puts $self "$args"}
  eof   {return [eof $self]}
  close {close $self}
  name  {return $filename}
 }

 class TextFile { File } {} {
  =     { set filename "${open}.txt" ; set self [open $filename]}
 }

 class int {} {} {
  =  {set self [expr int(round($args))]}
  ++ {incr self}
 }

 TextFile F = -open chap2
 puts "Filename is [F name]"
 int i = 1
 while 1 {
  set line [ F gets]
  if [F eof] break
  puts "[i]:$line"
  i ++
 }
 F close
 
 .-.    .-. .---. .---. .-..-. | "Bill Gates is just a monocle
 | |__ / | \| |-< | |-<  >  /  | and a Persian Cat away from
 `----'`-^-'`-'`-'`-'`-' `-'   | being one of the bad guys in a
       My opinions only.       | James Bond movie." -- D Miller
======

<<categories>> Object Orientation | Package | Glossary