1# -*-mode: tcl; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*- 2# 3# $Id: Push.tcl,v 1.4 2003-01-22 02:59:02 mikeclarkson Exp $ 4# 5###### push.tcl ###### 6############################################################ 7# Netmath Copyright (C) 1998 William F. Schelter # 8# For distribution under GNU public License. See COPYING. # 9############################################################ 10 11 12 13# 14#----------------------------------------------------------------- 15# 16# pushl -- push VALUE onto a stack stored under KEY 17# 18# Results: 19# 20# Side Effects: 21# 22#---------------------------------------------------------------- 23# 24 25global __pushl_ar 26proc pushl { val key } { 27 global __pushl_ar 28 append __pushl_ar($key) " [list $val]" 29} 30 31 32# 33#----------------------------------------------------------------- 34# 35# peekl -- if a value has been pushl'd under KEY return the 36# last value otherwise return DEFAULT. If M is supplied, get the 37# M'th one pushed... M == 1 is the last one pushed. 38# Results: a previously pushed value or DEFAULT 39# 40# Side Effects: none 41# 42#---------------------------------------------------------------- 43# 44proc peekl {key default {m 1}} { 45 global __pushl_ar 46 if {![info exists __pushl_ar($key)]} { 47 return $default 48 } elseif { [catch { set val [set __pushl_ar($key) ] } ] } { 49 return $default 50 } else { 51 set n [llength $val] 52 if { $m > 0 && $m <= $n } { 53 return [lindex $val [incr n -$m]] 54 } else { 55 return $default 56 } 57 } 58} 59 60 61 62# 63#----------------------------------------------------------------- 64# 65# popl -- pop off last value stored under KEY, or else return DFLT 66# 67# Results: last VALUE stored or DEFAULT 68# 69# Side Effects: List stored under KEY becomes one shorter 70# 71#---------------------------------------------------------------- 72# 73proc popl { key dflt} { 74 global __pushl_ar 75 76 if { [catch { set val [set __pushl_ar($key) ] } ] } { 77 return $dflt 78 } else { 79 set n [llength $val] 80 set result [lindex $val [incr n -1]] 81 82 if { $n > 0 } { 83 set __pushl_ar($key) [lrange $val 0 [expr {$n -1}]] 84 } else { 85 unset __pushl_ar($key) 86 } 87 return $result 88 } 89} 90 91 92# 93#----------------------------------------------------------------- 94# 95# clearl -- clear the list stored under KEY 96# 97# Result: none 98# 99# Side Effects: clear the list stored under KEY 100# 101#---------------------------------------------------------------- 102# 103proc clearl { key } { 104 global __pushl_ar 105 catch { unset __pushl_ar($key) } 106} 107 108 109 110## endsource push.tcl 111