Gadgets

Gadgets is another invention of RS

Description edit

Richard Suchenwirth 2001-04-06 21:37:59:

I have toyed with the gadget concept every now and then for years now (see tally: a string counter gadget or A matrix gadget), but here's a generalized approach. See also LOST for Larry Smith's extension to that.. and On Things for a more radical typeless approach.

I call gadgets "poor man's objects" - basically they are a variable (string, list or array) and a proc, both with the same name. The proc is renamed away when the variable dies. No inheritance (yet), no namespaces involved, but they offer a slick Tk-like API where you call the gadget's name with a minor command (method name) and possibly other parameters.

First, a look at the generalized API. You can specify a gadget type with methods, in which you can refer to 'args' for the method's arguments (parse'em yourself ;-) and 'self' for the variable itself, like this:

gadget type number {
   =     {set self [expr $args]}
   ++    {set self [expr $self+1]}
   round {set self [expr round($self)]} 
   sqrt  {expr sqrt($self)} 
}
gadget type int {
   =  {set self [expr {round($args)}]}
   ++ {incr self}
}
gadget type Array {
   = - += {eval array set self $args }
   -=     {catch {unset self($args)}}
   @      {set self($args)}
   empty  {expr [array size self]==0}
   names  {array names self}
   {}     {array get self}
}
gadget type List {
   =      {eval set self $args}
   +=     {lappend self $args}
   @      {lindex $self $args}
   empty  {expr [llength $self]==0}
   sort   {lsort $self}
   length {llength $self}
}
gadget type File {
  =     {set self [eval open $args]}
  >>    {upvar $args var; expr [gets $self var]+1}
  <<    {puts $self $args}
  eof   {eof $self}
  open? {expr ![catch {seek $self 0 current}]}
  close {close $self} 
}

For a defined gadget type, you can call a "constructor" with a name, and possibly an initialization:

number N = 1.5
Array  A
List   L = {foo bar}

For a "destructor", we just reuse the good old [unset] wheel.

Now you can use these variables or procs as you wish, with the addition that calling a (non-array) gadget proc without arguments returns its value, so [N] is a new alternative to $N and [set N]:

N = [N] * $N        ;# -> 2.25 (just for the fun of it ;)
set A(cat) Katze    ;# -> Katze
A names             ;# -> cat
L += grill
L = [L sort]
puts "[L] has [L length] elements, second is [L @ 1]"
#; -> bar foo grill has 3 elements, second is foo
File F = gadget.tcl
int i = 1
while {[F >> line]} {
    puts [i]:$line
    i ++
}
F close

Yes, this is still Tcl, and no, it's not like in the book. You can adjust the language pretty much to your likings via the method names. Arithmetic assignments look almost like all the world expects them to look (cf. Radical language modification, where I tried the same goal with the unknown command), and by pressing the assigned value through [expr] via number = or int = method, some typechecking is introduced.

The polymorphism (same method names for different types) allows some hiding of internal quirks, e.g. now you can increment a double like an int with ++, by just adding 1 to it, resp. calling [incr]. Notice also the polymorphism of += for lists vs. arrays: append an element, or set a key-value pair.

For introspection, you can get the types and names defined, and each gadget tells his type if asked:

gadget types     ;# -> number int Array List File
gadget names     ;# -> N A L F
N type           ;# -> number

Book-keeping of names and types is done not with global variables, but with procs whose bodies are rewritten when needed. [proc gadget::names] shows how that's done: start with a argumentless list command, append a new name on gadget creation, lreplace the name out on gadget destruction.

OK, so here's the code that does that (not very long, but not the easiest reading either - after all you write a proc that writes a proc that writes a proc ;-): The switch line containing 'type' did not work on my system: adding eval worked like a charm. Has there been a change in how the switch command works since 2002? -- Jim Hinds

History edit

PYK 2013-11-29: Added namespace, and test suite; made generated code more robust by encapsulating interpolated values in list format.

Code edit

#! /bin/env tclsh

namespace eval gadget {
namespace export *
namespace ensemble create
proc gadget {cmd args} {
    switch -- $cmd {
        names   names
        type    {type {*}$args}
        types   types
        default {return -code error "$cmd? should be name, type, or types"}
    }
}
proc types {} {}
proc names {} {}

proc type {type methods} {
    if {[namespace which [namespace current]::$type] ne {}} {
        return -code error "type $type redefines existing command"
    }
    set types [gadget types]
    if {$type ni $types} {
        proc [namespace current]::types {} [list return [list {*}$types $type]]
    }
    set template {
        proc @type@ {name args} {
            set ns [uplevel namespace current]
            if {$name eq {}} {
                set name [lindex $args 0]
                upvar 2 $name self
                set rest [lindex $args 1]
                set cmd  [lindex $rest 0]
                set args [lrange $rest 1 end]
                switch -- $cmd {
                    type {return @type@}
                    @methods@
                    {} {set self}
                    default {return -code error\
                            "$cmd? Should be one of: [list type {*}@cmds@]"}
                }
            } else {
                if {[namespace which ${ns}::$name] ne {}} {
                    error "gadget $name redefines existing command"
                }
                trace variable ${ns}::$name u [list [namespace current] unset $ns]
                proc [namespace current]::names {} [list  {*}[info body [namespace current]::names] ${ns}::$name]
                proc ${ns}::$name {args} "[list [namespace current]] @type@ {} [list $name] \$args"
                if {[llength $args]} {uplevel [list ${ns}::$name] $args}
            }
        }
    }
    set cmds {} 
    foreach {cmd -} $methods {lappend cmds $cmd}
    set template [string map [list @cmds@ $cmds @type@ [
        list $type] @methods@ $methods] $template[set template {}]]
    if 1 $template
    set type
}

proc unset {ns name el -} {
    if {$el eq {}} {
        rename ${ns}::$name {}
        set names [info body [namespace current]::names]
        set where [lsearch $names ${ns}::$name]
        proc [namespace current]::names {} [lreplace $names $where $where]
    }
}

proc test {} {namespace eval test {
    package require tcltest
    namespace import ::tcltest::*

    gadget type number {
       =     {set self [expr $args]}
       ++    {set self [expr $self+1]}
       round {set self [expr round($self)]} 
       sqrt  {expr sqrt($self)} 
    }

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


    gadget type Array {
       = - += {eval array set self $args }
       -=     {catch {unset self($args)}}
       @      {set self($args)}
       empty  {expr [array size self]==0}
       names  {array names self}
       {}     {array get self}
    }

    gadget type List {
       =      {eval set self $args}
       +=     {lappend self $args}
       @      {lindex $self $args}
       empty  {expr [llength $self]==0}
       sort   {lsort $self}
       length {llength $self}
    }

    gadget type File {
      =     {set self [eval open $args]}
      >>    {upvar $args var; expr [gets $self var]+1}
      <<    {puts $self $args}
      eof   {eof $self}
      open? {expr ![catch {seek $self 0 current}]}
      close {close $self} 
    }

    test gadgets {} {
        gadget number N = 1.5
        gadget Array A
        gadget List L = {foo bar}

        N = [N] * $N        ;# -> 2.25 (just for the fun of it ;)
        lappend res [N]

        #test bad method
        catch {N flyawayhome} eres eopts
        lappend res $eres 

        set A(cat) Katze    ;# -> Katze
        lappend res $A(cat)

        lappend res [A names]             ;# -> cat

        L += grill
        L = [L sort]
        lappend res "[L] has [L length] elements, second is [L @ 1]"
        #; -> bar foo grill has 3 elements, second is foo

        lappend res [gadget types]

        unset N
        catch {N} eres eopts
        lappend res "invalid command after unset: [string match {*invalid command name*} $eres]"

        return $res
    } [list 2.25 \
        {flyawayhome? Should be one of: type = ++ round sqrt} \
        Katze \
        cat \
        {bar foo grill has 3 elements, second is foo} \
        {number int Array List File} \
        {invalid command after unset: 1}
    ]

    cleanupTests
}}

}



if { [info exists argv0] || [file tail [info script]] eq [file tail $argv0]} {
        gadget::test
}

Notes: Gadgets can be passed by name in proc calls, where you either reuse the same name, or register the upvar variable:

upvar $name $name ;# or:
upvar $name var; [$name type] var

In order to avoid conflicts, gadget names should be unique and should not use existing command (C or Tcl) names. This prevents one from accidentally rewriting "set" or other Tcl essentials. Drawback: gadgets with same name cannot be used in recursive procs.

Shorter and Sweeter:

Larry Smith (mailto:larry(...at

sign...)smith-house.org) reverse-engineered an example I put on comp.lang.tcl and came to this beautiful short solution:

proc gadget { unused type methods } {
    set typeproc {
        set typeproc {
            upvar @var self
            @type self $method $args
        }
        upvar $var self
        if { "$method" == "" } {
            return $self
        }
        switch $method {
            @methods
        }
        regsub @var $typeproc $var typeproc
        proc $var { { method "" } args } $typeproc
    }
    regsub @type $typeproc $type typeproc
    regsub @methods $typeproc $methods typeproc
    proc $type { var method args } $typeproc
}

RS: I find it more legible, though, if all four mentions of typeproc inside the first set typeproc .. are replaced by instproc, as that is dealing with the instance proc anyway.

AMG: The [regsub]s can be replaced with [string map]s:

proc $var {{method {}} args} [string map [list @var $var] $typeproc]
proc $type {var method args} [string map [list @type $type @methods $methods] $typeproc]

Whoa, to avoid unwanted expansion, better put an extra level of listiness in there:

[string map [list @var [list $var]] $typeproc]

You can even lose the $typeproc variables, instead directly including the template. To make things easier still, make a helper procedure to do the string mapping. Yet more: make that helper procedure itself make procedures!

proc proc_template {name lazy_args eager_args body} {
    set map [list]
    foreach varname $eager_args {
        upvar 1 $varname var
        lappend map @$varname@ [list $var]
    }
    proc $name $lazy_args [string map $map $body]
}

proc gadget {unused type methods} {
    proc_template $type {var method args} {type methods} {
        upvar $var self
        if {$method eq ""} {
            return $self
        }
        switch $method @methods@
        proc_template $var {{method ""} args} {var} {
            upvar @var@ self
            @type@ self $method $args
        }
    }
}

There's a pitfall here, though:

gadget type @var@ {= {set self [expr $args]}}
@var@ name = 5
name
ERROR: too many nested evaluations

The outer [proc_template] expands the inner @type@ to @var@, and the inner [proc_template] expands both @var@s to name, resulting in proc name {{method ""} args} {upvar name self; name self $method $args}. Bad!

Does anyone have any suggestions for how to make this safe?

Method inheritance (even multiple) can be had cheaply if the methods to be inherited are spliced in after @methods above. The switch might sometimes run longer, but every method not defined for your type would fall through to the first inherited method of same name.

Category Object Orientation

Arts and crafts of Tcl-Tk programming