URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [libgui/] [library/] [list.tcl] - Blame information for rev 1782

Go to most recent revision | Details | Compare with Previous | View Log


# 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
  }
}

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

Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [libgui/] [library/] [list.tcl] - Blame information for rev 1782