blob: ae8cf29f4698e07025527b2a15e170e72d216b6d (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
# list.tcl - Some handy list procs.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
# FIXME: some are from TclX; we should probably just use the C
# implementation that is in S-N.
proc lvarpush {listVar element {index 0}} {
upvar $listVar var
if {![info exists var]} then {
lappend var $element
} else {
set var [linsert $var $index $element]
}
}
proc lvarpop {listVar {index 0}} {
upvar $listVar var
set result [lindex $var $index]
# NOTE lreplace can fail if list is empty.
if {! [catch {lreplace $var $index $index} new]} then {
set var $new
}
return $result
}
proc lassign {list args} {
set len [expr {[llength $args] - 1}]
# Special-case last element: if LIST is longer than ARGS, assign a
# list of leftovers to the last variable.
if {[llength $list] - 1 > $len} then {
upvar [lindex $args $len] local
set local [lrange $list $len end]
incr len -1
}
while {$len >= 0} {
upvar [lindex $args $len] local
set local [lindex $list $len]
incr len -1
}
}
# Remove duplicates and sort list. ARGS are arguments to lsort, eg
# --increasing.
proc lrmdups {list args} {
set slist [eval lsort $args [list $list]]
set last [lvarpop slist]
set result [list $last]
foreach item $slist {
if {$item != $last} then {
set last $item
lappend result $item
}
}
return $result
}
proc lremove {list element} {
set index [lsearch -exact $list $element]
if {$index == -1} then {
return $list
}
return [lreplace $list $index $index]
}
# replace element with new element
proc lrep {list element new} {
set index [lsearch -exact $list $element]
if {$index == -1} {
return $list
}
return [lreplace $list $index $index $new]
}
# FIXME: this isn't precisely like the C lvarcat. It is slower.
proc lvarcat {listVar args} {
upvar $listVar var
if {[join $args] != ""} then {
# Yuck!
eval eval lappend var $args
}
}
|
