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