Version 14 of forward-compatible dict

Updated 2014-05-21 17:52:09 by AMG

As I like the new dict command very much, I want to use it in all my new projects. But I don't want my programs to need tcl 8.5!

Here is a pure tcl emulation of dict command.

Vince -- this is very useful indeed. Thanks!

The new dict update and dict with are not yet supported here. Any contributions?

PS I created a dict package based on the current (Nov2005) code of Tcl 8.5, which has all the features and most of the performance of the real thing. See the dict page, search for 'tclDict'

Here's an ugly 'dict update' implementation. Any improvements?

proc _dict_update {dvar args} {
    set name [string map {: {} ( {} ) {}} $dvar]
    upvar 1 $dvar dv
    upvar 1 _my_dict_array$name local

    array set local $dv
    foreach {k v} [lrange $args 0 end-1] {
        if {[info exists local($k)]} {
            if {![uplevel 1 [list info exists $v]]} {
                uplevel 1 [list upvar 0 _my_dict_array${name}($k) $v]
            } else {
                uplevel 1 [list set $v $local($k)]
            }
        }
    }
    set code [catch {uplevel 1 [lindex $args end]} res]

    foreach {k v} [lrange $args 0 end-1] {
        if {[uplevel 1 [list info exists $v]]} {
            set local($k) [uplevel 1 [list set $v]]
        } else {
            unset -nocomplain local($k)
        }
    }
    set dv [array get local]
    unset local

    return -code $code $res
}

# Poor man's dict -- a pure tcl [dict] emulation
# Very slow, but complete.
#
# Not all error checks are implemented!
# e.g. [dict create odd arguments here] will work
#
# Implementation is based on lists, [array set/get]
# and recursion

if {![llength [info commands dict]]} {
    proc dict {cmd args} {
        uplevel 1 [linsert $args 0 _dict_$cmd]
    }
    proc _dict_get {dv args} {
        if {![llength $args]} {return $dv} else {
            array set dvx $dv
            set key [lindex $args 0]
            set dv $dvx($key)
            set args [lrange $args 1 end]
            return [eval [linsert $args 0 _dict_get $dv]]
        }
    }
    proc _dict_exists {dv key args} {
        array set dvx $dv
        set r [info exists dvx($key)]
        if {!$r} {return 0}
        if {[llength $args]} {
            return [eval [linsert $args 0 _dict_exists $dvx($key) ]]
        } else {return 1}
    }
    proc _dict_set {dvar key value args } {
        upvar 1 $dvar dv
        if {![info exists dv]} {set dv [list]}
        array set dvx $dv
        if {![llength $args]} {
            set dvx($key) $value
        } else {
            eval [linsert $args 0 _dict_set dvx($key) $value]
        }
        set dv [array get dvx]
    }
    proc _dict_unset {dvar key args} {
        upvar 1 $dvar mydvar
        if {![info exists mydvar]} {return}
        array set dv $mydvar
        if {![llength $args]} {
            if {[info exists dv($key)]} {
                unset dv($key)
            }
        } else {
            eval [linsert $args 0 _dict_unset dv($key) ]
        }
        set mydvar [array get dv]
        return {}
    }
    proc _dict_keys {dv {pat *}} {
        array set dvx $dv
        return [array names dvx $pat]
    }
    proc _dict_append {dvar key {args}} {
        upvar 1 $dvar dv
        if {![info exists dv]} {set dv [list]}
        array set dvx $dv
        eval [linsert $args 0 append dvx($key) ]
        set dv [array get dvx]
    }
    proc _dict_create {args} {
        return $args
    }
    proc _dict_filter {dv ftype args} {
        set r [list]
        foreach {globpattern} $args {break}
        foreach {varlist script} $args {break}

        switch $ftype {
            key {
                foreach {key value} $dv {
                    if {[string match $globpattern $key]} {
                        lappend r $key $value
                    }
                }
            }
            value {
                foreach {key value} $dv {
                    if {[string match $globpattern $value]} {
                        lappend r $key $value
                    }
                }
            }
            script {
                foreach {Pkey Pval} $varlist {break}
                upvar 1 $Pkey key $Pval value
                foreach {key value} $dv {
                    if {[uplevel 1 $script]} {
                        lappend r $key $value
                    }
                }
            }
            default {
                error "Wrong filter type"
            }
        }
        return $r
    }
    proc _dict_for {kv dict body} {
        uplevel 1 [list foreach $kv $dict $body]
    }
    proc _dict_incr {dvar key {incr 1}} {
        upvar 1 $dvar dv
        if {![info exists dv]} {set dv [list]}
        array set dvx $dv
        if {![info exists dvx($key)]} {set dvx($key) 0}
        incr dvx($key) $incr
        set dv [array get dvx]
    }
    proc _dict_info {dv} {
        return "Dictionary is represented as plain list"
    }
    proc _dict_lappend {dvar key args} {
        upvar 1 $dvar dv
        if {![info exists dv]} {set dv [list]}
        array set dvx $dv
        eval [linsert $args 0 lappend dvx($key)]
        set dv [array get dvx]
    }
    proc _dict_merge {args} {
        foreach dv $args {
            array set dvx $dv
        }
        array get dvx
    }
    proc _dict_replace {dv args} {
        foreach {k v} $args {
            _dict_set dv $k $v
        }
        return $dv
    }
    proc _dict_remove {dv args} {
        foreach k $args {
            _dict_unset dv $k
        }
        return $dv
    }
    proc _dict_size {dv} {
        return [expr {[llength $dv]/2}]
    }
    proc _dict_values {dv {gp *}} {
        set r [list]
        foreach {k v} $dv {
            if {[string match $gp $v]} {
                lappend r $v
            }
        }
        return $r
    }
}

Anton Kovalenko

28jan04 jcw - The "ihash" package in critlib [L1 ] might be a way to get good performance (from C, i.e. with a Tcl extension, not a core change). See also the Adding a hashed datatype page where this extension is described in more detail.

RHS 20Sept2004 I included this code in the .tgz file for RHS's Bytecode Package. I wasn't sure who to ask about doing this, but I assumed it was ok, since its on the Wiki and my code is released open source (standard Tclish license). I made a note in the dict.tcl file that the code in that file is not copyrighted to me, and put a link to this page. If my including this file is an issue, let me know and I'll remove it.