Version 5 of LOST

Updated 2012-09-21 01:17:58 by RLE

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

---