# stack.tcl --
#
# Stack implementation for Tcl.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: stack_tcl.tcl,v 1.3 2010/03/15 17:17:38 andreas_kupries Exp $
namespace eval ::struct::stack {
# counter is used to give a unique name for unnamed stacks
variable counter 0
# Only export one command, the one used to instantiate a new stack
namespace export stack_tcl
}
# ::struct::stack::stack_tcl --
#
# Create a new stack with a given name; if no name is given, use
# stackX, where X is a number.
#
# Arguments:
# name name of the stack; if null, generate one.
#
# Results:
# name name of the stack created
proc ::struct::stack::stack_tcl {args} {
variable I::stacks
variable counter
switch -exact -- [llength [info level 0]] {
1 {
# Missing name, generate one.
incr counter
set name "stack${counter}"
}
2 {
# Standard call. New empty stack.
set name [lindex $args 0]
}
default {
# Error.
return -code error \
"wrong # args: should be \"stack ?name?\""
}
}
# FIRST, qualify the name.
if {![string match "::*" $name]} {
# Get caller's namespace; append :: if not global namespace.
set ns [uplevel 1 [list namespace current]]
if {"::" != $ns} {
append ns "::"
}
set name "$ns$name"
}
if {[llength [info commands $name]]} {
return -code error \
"command \"$name\" already exists, unable to create stack"
}
set stacks($name) [list ]
# Create the command to manipulate the stack
interp alias {} $name {} ::struct::stack::StackProc $name
return $name
}
##########################
# Private functions follow
# ::struct::stack::StackProc --
#
# Command that processes all stack object commands.
#
# Arguments:
# name name of the stack object to manipulate.
# args command name and args for the command
#
# Results:
# Varies based on command to perform
if {[package vsatisfies [package provide Tcl] 8.5]} {
# In 8.5+ we can do an ensemble for fast dispatch.
proc ::struct::stack::StackProc {name cmd args} {
# Shuffle method to front and then simply run the ensemble.
# Dispatch, argument checking, and error message generation
# are all done in the C-level.
I $cmd $name {*}$args
}
namespace eval ::struct::stack::I {
namespace export clear destroy get getr peek peekr \
trim trim* pop push rotate size
namespace ensemble create
}
} else {
# Before 8.5 we have to code our own dispatch, including error
# checking.
proc ::struct::stack::StackProc {name cmd args} {
# Do minimal args checks here
if { [llength [info level 0]] == 2 } {
return -code error "wrong # args: should be \"$name option ?arg arg ...?\""
}
# Split the args into command and args components
if {![llength [info commands ::struct::stack::I::$cmd]]} {
set optlist [lsort [info commands ::struct::stack::I::*]]
set xlist {}
foreach p $optlist {
set p [namespace tail $p]
if {($p eq "K") || ($p eq "lreverse")} continue
lappend xlist $p
}
set optlist [linsert [join $xlist ", "] "end-1" "or"]
return -code error \
"bad option \"$cmd\": must be $optlist"
}
uplevel 1 [linsert $args 0 ::struct::stack::I::$cmd $name]
}
}
# ### ### ### ######### ######### #########
namespace eval ::struct::stack::I {
# The stacks array holds all of the stacks you've made
variable stacks
}
# ### ### ### ######### ######### #########
# ::struct::stack::I::clear --
#
# Clear a stack.
#
# Arguments:
# name name of the stack object.
#
# Results:
# None.
proc ::struct::stack::I::clear {name} {
variable stacks
set stacks($name) {}
return
}
# ::struct::stack::I::destroy --
#
# Destroy a stack object by removing it's storage space and
# eliminating it's proc.
#
# Arguments:
# name name of the stack object.
#
# Results:
# None.
proc ::struct::stack::I::destroy {name} {
variable stacks
unset stacks($name)
interp alias {} $name {}
return
}
# ::struct::stack::I::get --
#
# Retrieve the whole contents of the stack.
#
# Arguments:
# name name of the stack object.
#
# Results:
# items list of all items in the stack.
proc ::struct::stack::I::get {name} {
variable stacks
return [lreverse $stacks($name)]
}
proc ::struct::stack::I::getr {name} {
variable stacks
return $stacks($name)
}
# ::struct::stack::I::peek --
#
# Retrieve the value of an item on the stack without popping it.
#
# Arguments:
# name name of the stack object.
# count number of items to pop; defaults to 1
#
# Results:
# items top count items from the stack; if there are not enough items
# to fulfill the request, throws an error.
proc ::struct::stack::I::peek {name {count 1}} {
variable stacks
upvar 0 stacks($name) mystack
if { $count < 1 } {
return -code error "invalid item count $count"
} elseif { $count > [llength $mystack] } {
return -code error "insufficient items on stack to fill request"
}
if { $count == 1 } {
# Handle this as a special case, so single item peeks are not
# listified
return [lindex $mystack end]
}
# Otherwise, return a list of items
incr count -1
return [lreverse [lrange $mystack end-$count end]]
}
proc ::struct::stack::I::peekr {name {count 1}} {
variable stacks
upvar 0 stacks($name) mystack
if { $count < 1 } {
return -code error "invalid item count $count"
} elseif { $count > [llength $mystack] } {
return -code error "insufficient items on stack to fill request"
}
if { $count == 1 } {
# Handle this as a special case, so single item peeks are not
# listified
return [lindex $mystack end]
}
# Otherwise, return a list of items, in reversed order.
incr count -1
return [lrange $mystack end-$count end]
}
# ::struct::stack::I::trim --
#
# Pop items off a stack until a maximum size is reached.
#
# Arguments:
# name name of the stack object.
# count requested size of the stack.
#
# Results:
# item List of items trimmed, may be empty.
proc ::struct::stack::I::trim {name newsize} {
variable stacks
upvar 0 stacks($name) mystack
if { ![string is integer -strict $newsize]} {
return -code error "expected integer but got \"$newsize\""
} elseif { $newsize < 0 } {
return -code error "invalid size $newsize"
} elseif { $newsize >= [llength $mystack] } {
# Stack is smaller than requested, do nothing.
return {}
}
# newsize < [llength $mystack]
# pop '[llength $mystack]' - newsize elements.
if {!$newsize} {
set result [lreverse [K $mystack [unset mystack]]]
set mystack {}
} else {
set result [lreverse [lrange $mystack $newsize end]]
set mystack [lreplace [K $mystack [unset mystack]] $newsize end]
}
return $result
}
proc ::struct::stack::I::trim* {name newsize} {
if { ![string is integer -strict $newsize]} {
return -code error "expected integer but got \"$newsize\""
} elseif { $newsize < 0 } {
return -code error "invalid size $newsize"
}
variable stacks
upvar 0 stacks($name) mystack
if { $newsize >= [llength $mystack] } {
# Stack is smaller than requested, do nothing.
return
}
# newsize < [llength $mystack]
# pop '[llength $mystack]' - newsize elements.
# No results, compared to trim.
if {!$newsize} {
set mystack {}
} else {
set mystack [lreplace [K $mystack [unset mystack]] $newsize end]
}
return
}
# ::struct::stack::I::pop --
#
# Pop an item off a stack.
#
# Arguments:
# name name of the stack object.
# count number of items to pop; defaults to 1
#
# Results:
# item top count items from the stack; if the stack is empty,
# returns a list of count nulls.
proc ::struct::stack::I::pop {name {count 1}} {
variable stacks
upvar 0 stacks($name) mystack
if { $count < 1 } {
return -code error "invalid item count $count"
}
set ssize [llength $mystack]
if { $count > $ssize } {
return -code error "insufficient items on stack to fill request"
}
if { $count == 1 } {
# Handle this as a special case, so single item pops are not
# listified
set item [lindex $mystack end]
if {$count == $ssize} {
set mystack [list]
} else {
set mystack [lreplace [K $mystack [unset mystack]] end end]
}
return $item
}
# Otherwise, return a list of items, and remove the items from the
# stack.
if {$count == $ssize} {
set result [lreverse [K $mystack [unset mystack]]]
set mystack [list]
} else {
incr count -1
set result [lreverse [lrange $mystack end-$count end]]
set mystack [lreplace [K $mystack [unset mystack]] end-$count end]
}
return $result
# -------------------------------------------------------
set newsize [expr {[llength $mystack] - $count}]
if {!$newsize} {
set result [lreverse [K $mystack [unset mystack]]]
set mystack {}
} else {
set result [lreverse [lrange $mystack $newsize end]]
set mystack [lreplace [K $mystack [unset mystack]] $newsize end]
}
if {$count == 1} {
set result [lindex $result 0]
}
return $result
}
# ::struct::stack::I::push --
#
# Push an item onto a stack.
#
# Arguments:
# name name of the stack object
# args items to push.
#
# Results:
# None.
if {[package vsatisfies [package provide Tcl] 8.5]} {
proc ::struct::stack::I::push {name args} {
if {![llength $args]} {
return -code error "wrong # args: should be \"$name push item ?item ...?\""
}
variable stacks
upvar 0 stacks($name) mystack
lappend mystack {*}$args
return
}
} else {
proc ::struct::stack::I::push {name args} {
if {![llength $args]} {
return -code error "wrong # args: should be \"$name push item ?item ...?\""
}
variable stacks
upvar 0 stacks($name) mystack
if {[llength $args] == 1} {
lappend mystack [lindex $args 0]
} else {
eval [linsert $args 0 lappend mystack]
}
return
}
}
# ::struct::stack::I::rotate --
#
# Rotate the top count number of items by step number of steps.
#
# Arguments:
# name name of the stack object.
# count number of items to rotate.
# steps number of steps to rotate.
#
# Results:
# None.
proc ::struct::stack::I::rotate {name count steps} {
variable stacks
upvar 0 stacks($name) mystack
set len [llength $mystack]
if { $count > $len } {
return -code error "insufficient items on stack to fill request"
}
# Rotation algorithm:
# do
# Find the insertion point in the stack
# Move the end item to the insertion point
# repeat $steps times
set start [expr {$len - $count}]
set steps [expr {$steps % $count}]
if {$steps == 0} return
for {set i 0} {$i < $steps} {incr i} {
set item [lindex $mystack end]
set mystack [linsert \
[lreplace \
[K $mystack [unset mystack]] \
end end] $start $item]
}
return
}
# ::struct::stack::I::size --
#
# Return the number of objects on a stack.
#
# Arguments:
# name name of the stack object.
#
# Results:
# count number of items on the stack.
proc ::struct::stack::I::size {name} {
variable stacks
return [llength $stacks($name)]
}
# ### ### ### ######### ######### #########
proc ::struct::stack::I::K {x y} { set x }
if {![llength [info commands lreverse]]} {
proc ::struct::stack::I::lreverse {x} {
# assert (llength(x) > 1)
set l [llength $x]
if {$l <= 1} { return $x }
set r [list]
while {$l} { lappend r [lindex $x [incr l -1]] }
return $r
}
}
# ### ### ### ######### ######### #########
## Ready
namespace eval ::struct {
# Get 'stack::stack' into the general structure namespace for
# pickup by the main management.
namespace import -force stack::stack_tcl
}
