if 0 {[Richard Suchenwirth] 2005-03-17 - [Jim] is a fantastic
proving-ground for "tomorrow's Tcl today". As a super-subset of [Tcl], it adds
very interesting new features, while lacking many others
(from [regexp] to [Unicode] support, [Tk], ...) I wanted to have my Tcl cake and
eat Jim too, so I hacked up this "Jimulation" that runs in my 8.4.5 (on
W95!), and provides exactly those [Jim] features needed for
[Tiny OO with Jim]:
   * [proc] and [lambda] with optional [closures] (rather, [static variables])
   * [Jim references]
   * prefix math for + - * /
   * lmap 
[Garbage collection] is missing, though.- Feel free to add more as needed!
}
 catch {rename proc 'proc} ;#-- good for repeated sourcing
 'proc proc {name argl args} {
    switch [llength $args] {
        1   {foreach {body stat} $args break ;# dirty trick yet elegant :)}
        2   {foreach {stat body} $args break}
        default {error "usage: proc name arglist ?statics? body"}
    }
    set prefix ""
    if [llength $stat] {
        namespace eval ::Jim {namespace eval closure {}}
        set ns ::Jim::closure::$name
        foreach var $stat {
            if {[llength $var]==1} {lappend var [uplevel 1 set $var]}
            namespace eval $ns [linsert $var 0 variable]
            set vname [lindex $var 0]
            append prefix "upvar 0 ${ns}::$vname $vname\n"
        }
     }
     'proc $name $argl $prefix$body
 }
#-- A first test, will also be needed in [lambda]...
 proc intgen {} {{i -1}} {incr i}
#-- ...and now for the anonymous function generator itself:
 'proc lambda {argl args} {
    switch [llength $args] {
        1   {foreach {body stat} $args break}
        2   {foreach {stat body} $args break}
        default {error "usage: lambda arglist ?statics? body"}
    }
    K [set name lambda[intgen]] \
        [uplevel 1 [list proc $name $argl $stat $body]]
 }
#-- I couldn't resist to use the glorious [K] combinator here :)
 proc K {a b} {set a}

#-- References are emulated by variables in a Jim::ref namespace:
 namespace eval ::Jim {namespace eval ref {}}
 
 proc ref {value tag} {K [set handle $tag[intgen]] [setref $handle $value]}
 proc getref  handle        {set ::Jim::ref::$handle}
 proc setref {handle value} {set ::Jim::ref::$handle $value}

#-- Testing references with the example from [Jim closures]:
 set countRef [ref 0 int]
 proc make-counter {} {
     global countRef
     lambda {} countRef {
         K [set n [+ [getref $countRef] 1]] [setref $countRef $n]
     }
 }
 set f [make-counter]
 set g [make-counter]
 puts "[$f] [$g] [$f] [$g] [$f] [$g]" ;# should print 1 2 3 4 5 6

#-- export [expr] operators as prefix binary functions:
 foreach op {+ - * /} {'proc $op {a b} "expr {\$a $op \$b}"}
#-- [[lmap]] (a "collecting [foreach]") is a good one, too:
 'proc lmap {_var list body} {
    upvar 1 $_var e
    set res {}
    foreach e $list {lappend res [uplevel 1 $body]}
    set res
 }
#-- quick test: 
 puts [lmap i {1 2 3 4} {* $i $i}]
if 0 {should print
 1 4 9 16
Now for the proof of the pudding: the code from [Tiny OO with Jim]
should work if I've done it all right... and it does here :}
 source bank.tcl
if 0 {
----
[Arts and crafts of Tcl-Tk programming] [Category Jim]
}

------------------
For those who dont like namespaces is version posted by kruzalex

catch {rename proc 'proc} ;#-- good for repeated sourcing
'proc proc {name argl args} {
    switch [llength $args] {
        1   {foreach {body stat} $args break ;# dirty trick yet elegant :)}
        2   {foreach {stat body} $args break}
        default {error "usage: proc name arglist ?statics? body"}
    }
    set prefix ""
    if [llength $stat] {
        foreach var $stat {
            if {[llength $var]==1} {lappend var [uplevel 1 set $var]}
            set vname [lindex $var 0]
            set ::$vname [lindex $var 1]
            append prefix "upvar 0 ::$vname $vname\n"
        }
     }
     'proc $name $argl $prefix$body
 }

'proc lambda {argl args} {
    switch [llength $args] {
        1   {foreach {body stat} $args break}
        2   {foreach {stat body} $args break}
        default {error "usage: lambda arglist ?statics? body"}
    }
    set name lambda[intgen]
    uplevel 1 [list proc $name $argl $stat $body]
    set name
 }

proc intgen {} {{i -1}} {incr i} 

 proc ref {value tag} {
         set handle $tag[intgen] 
         setref $handle $value
         }
         

  proc getref  handle        {set $handle}
 proc setref {handle value} {set $handle $value}

set countRef [ref 0 int]

foreach op {+ - * /} {'proc $op {a b} "expr {\$a $op \$b}"}