interfaces/xmaxima/Tkmaxima/Push.tcl

   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
  25 global __pushl_ar
  26 proc 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 #
  44 proc 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 #
  73 proc 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 #
 103 proc clearl { key } {
 104     global __pushl_ar
 105     catch { unset __pushl_ar($key) }
 106 }
 107
 108
 109
 110 ## endsource push.tcl