Adding error message when shmat fails - naim
[dyninst.git] / paradyn / tcl / generic.tcl
1 # generic.tcl
2 # Ariel Tamches
3
4 # Routines I have found useful across all my tk4.0 programs
5
6 proc resize1Scrollbar {sbname newTotal newVisible} {
7    # This is a nice n' generic routine  --ari
8    # However, it is (currently) only called from C++ code.  If this
9    # situation doesn't change, then we might want to just
10    # zap this and turn it into C++ code...
11
12    # 'newTotal' and 'newVisible' are tentative values;
13    # We use them to calculate 'newFirst' and 'newLast'.
14    # We make an effort to keep 'newFirst' as close as possible to 'oldFirst'.
15
16    set oldConfig [$sbname get]
17    set oldFirst  [lindex $oldConfig 0]
18    set oldLast   [lindex $oldConfig 1]
19 #   puts stderr "newTotal=$newTotal; newVisible=$newVisible; oldFirst=$oldFirst; oldLast=$oldLast"
20
21    if {$newVisible < $newTotal} {
22       # The usual case: not everything fits
23       set fracVisible [expr 1.0 * $newVisible / $newTotal]
24 #      puts stderr "newVisible=$newVisible; newTotal=$newTotal; fracVisible=$fracVisible"
25
26       set newFirst $oldFirst
27       set newLast [expr $newFirst + $fracVisible]
28
29 #      puts stderr "tentative newFirst=$newFirst; newLast=$newLast"
30
31       if {$newLast > 1.0} {
32          set theOverflow [expr $newLast - 1.0]
33 #         puts stderr "resize1Scrollbar: would overflow by fraction of $theOverflow; moving newFirst back"
34
35          set newFirst [expr $oldFirst - $theOverflow]
36          set newLast  [expr $newFirst + $fracVisible]
37       } else {
38 #         puts stderr "resize1Scrollbar: yea, we were able to keep newFirst unchanged at $newFirst"
39       }
40    } else {
41       # the unusual case: everything fits (visible >= total)
42 #      puts stderr "everything fits"
43       set newFirst 0.0
44       set newLast  1.0
45    }
46
47    if {$newFirst < 0} {
48       # This is an assertion failure
49       puts stderr "resize1Scrollbar warning: newFirst is $newFirst"
50    }
51    if {$newLast > 1} {
52       # This is an assertion failure
53       puts stderr "resize1Scrollbar warning: newLast is $newLast"
54    }
55
56    $sbname set $newFirst $newLast
57    return $newFirst
58 }