Jimulation

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   {lassign $args body stat}
        2   {lassign $args stat body}
        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   {lassign $args body stat}
        2   {lassign $args stat body}
        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   {lassign $args body stat}
        2   {lassign $args stat body}
        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   {lassign $args body stat}
        2   {lassign $args stat body}
        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}"}