URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [dejagnu/] [lib/] [debugger.exp] - Blame information for rev 1774

Go to most recent revision | Details | Compare with Previous | View Log


# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc.
 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
# Please email any bugs, comments, and/or additions to this file to:
# bug-dejagnu@prep.ai.mit.edu
 
# This file was written by Rob Savoye. (rob@cygnus.com)
 
#
# Dump the values of a shell expression representing variable
# names.
proc dumpvars { args } {
    uplevel 1 [list foreach i [uplevel 1 "info vars $args"] {
        if { [catch "array names $i" names ] } {
            eval "puts \"${i} = \$${i}\""
        } else {
            foreach k $names {
                eval "puts \"$i\($k\) = \$$i\($k\)\""
            }
        }
    }
       ]
}
 
#
# dump the values of a shell expression representing variable
# names.
proc dumplocals { args } {
    uplevel 1 [list foreach i [uplevel 1 "info locals $args"] {
        if { [catch "array names $i" names ] } {
            eval "puts \"${i} = \$${i}\""
        } else {
            foreach k $names {
                eval "puts \"$i\($k\) = \$$i\($k\)\""
            }
        }
    }
       ]
}
#
# Dump the body of procedures specified by a regexp.
#
proc dumprocs { args } {
    foreach i [info procs $args] {
        puts "\nproc $i \{ [info args $i] \} \{ [info body $i]\}"
    }
}
 
#
# Dump all the current watchpoints
#
proc dumpwatch { args } {
    foreach i [uplevel 1 "info vars $args"] {
        set tmp ""
        if { [catch "uplevel 1 array name $i" names] } {
            set tmp [uplevel 1 trace vinfo $i]
            if ![string match "" $tmp] {
                puts "$i $tmp"
            }
        } else {
            foreach k $names {
                set tmp [uplevel 1 trace vinfo [set i]($k)]
                if ![string match "" $tmp] {
                    puts "[set i]($k) = $tmp"
                }
            }
        }
    }
}
 
#
# Trap a watchpoint for an array
#
proc watcharray { element type} {
    upvar [set array]($element) avar
    case $type {
        "w" { puts "New value of [set array]($element) is $avar" }
        "r" { puts "[set array]($element) (= $avar) was just read" }
        "u" { puts "[set array]($element) (= $avar) was just unset" }
    }
}
 
proc watchvar { v type } {
    upvar $v var
    case $type {
        "w" { puts "New value of $v is $var" }
        "r" { puts "$v (=$var) was just read" }
        "u" { puts "$v (=$var) was just unset" }
    }
}
 
#
# Watch when a variable is written
#
proc watchunset { arg } {
    if { [catch "uplevel 1 array name $arg" names ] } {
        if ![uplevel 1 info exists $arg] {
            puts stderr "$arg does not exist"
            return
        }
        uplevel 1 trace variable $arg u watchvar
    } else {
        foreach k $names {
            if ![uplevel 1 info exists $arg] {
                puts stderr "$arg does not exist"
                return
            }
            uplevel 1 trace variable [set arg]($k) u watcharray
        }
    }
}
 
#
# Watch when a variable is written
#
proc watchwrite { arg } {
    if { [catch "uplevel 1 array name $arg" names ] } {
        if ![uplevel 1 info exists $arg] {
            puts stderr "$arg does not exist"
            return
        }
        uplevel 1 trace variable $arg w watchvar
    } else {
        foreach k $names {
            if ![uplevel 1 info exists $arg] {
                puts stderr "$arg does not exist"
                return
            }
            uplevel 1 trace variable [set arg]($k) w watcharray
        }
    }
}
 
#
# Watch when a variable is read
#
proc watchread { arg } {
    if { [catch "uplevel 1 array name $arg" names ] } {
        if ![uplevel 1 info exists $arg] {
            puts stderr "$arg does not exist"
            return
        }
        uplevel 1 trace variable $arg r watchvar
    } else {
        foreach k $names {
            if ![uplevel 1 info exists $arg] {
                puts stderr "$arg does not exist"
                return
            }
            uplevel 1 trace variable [set arg]($k) r watcharray
        }
    }
}
 
#
# Delete a watch point
#
proc watchdel { args } {
    foreach i [uplevel 1 "info vars $args"] {
        set tmp ""
        if { [catch "uplevel 1 array name $i" names] } {
            catch "uplevel 1 trace vdelete $i w watchvar"
            catch "uplevel 1 trace vdelete $i r watchvar"
            catch "uplevel 1 trace vdelete $i u watchvar"
        } else {
            foreach k $names {
                catch "uplevel 1 trace vdelete [set i]($k) w watcharray"
                catch "uplevel 1 trace vdelete [set i]($k) r watcharray"
                catch "uplevel 1 trace vdelete [set i]($k) u watcharray"
            }
        }
    }
}
 
#
# This file creates GDB style commands for the Tcl debugger
#
proc print { var } {
    puts "$var"
}
 
proc quit { } {
    log_and_exit;
}
 
proc bt { } {
    puts "[w]"
}
 
#
# create some stub procedures since we can't alias the command names
#
proc dp { args } {
  uplevel 1 dumprocs $args
}
 
proc dv { args } {
  uplevel 1 dumpvars $args
}
 
proc dl { args } {
  uplevel 1 dumplocals $args
}
 
proc dw { args } {
    uplevel 1 dumpwatch $args
}
 
proc q { } {
    quit
}
 
proc p { args } {
    uplevel 1 print $args
}
 
proc wu { args } {
    uplevel 1 watchunset $args
}
 
proc ww { args } {
    uplevel 1 watchwrite $args
}
 
proc wr { args } {
    uplevel 1 watchread $args
}
 
proc wd { args } {
    uplevel 1 watchdel $args
}

Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [dejagnu/] [lib/] [debugger.exp] - Blame information for rev 1774

Line No.	Rev	Author	Line
1	578	markom	`# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc.`
2
3			`# This program is free software; you can redistribute it and/or modify`
4			`# it under the terms of the GNU General Public License as published by`
5			`# the Free Software Foundation; either version 2 of the License, or`
6			`# (at your option) any later version.`
7			`#`
8			`# This program is distributed in the hope that it will be useful,`
9			`# but WITHOUT ANY WARRANTY; without even the implied warranty of`
10			`# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the`
11			`# GNU General Public License for more details.`
12			`#`
13			`# You should have received a copy of the GNU General Public License`
14			`# along with this program; if not, write to the Free Software`
15			`# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.`
16
17			`# Please email any bugs, comments, and/or additions to this file to:`
18			`# bug-dejagnu@prep.ai.mit.edu`
19
20			`# This file was written by Rob Savoye. (rob@cygnus.com)`
21
22			`#`
23			`# Dump the values of a shell expression representing variable`
24			`# names.`
25			`proc dumpvars { args } {`
26			`uplevel 1 [list foreach i [uplevel 1 "info vars $args"] {`
27			`if { [catch "array names $i" names ] } {`
28			`eval "puts \"${i} = \$${i}\""`
29			`} else {`
30			`foreach k $names {`
31			`eval "puts \"$i\($k\) = \$$i\($k\)\""`
32			`}`
33			`}`
34			`}`
35			`]`
36			`}`
37
38			`#`
39			`# dump the values of a shell expression representing variable`
40			`# names.`
41			`proc dumplocals { args } {`
42			`uplevel 1 [list foreach i [uplevel 1 "info locals $args"] {`
43			`if { [catch "array names $i" names ] } {`
44			`eval "puts \"${i} = \$${i}\""`
45			`} else {`
46			`foreach k $names {`
47			`eval "puts \"$i\($k\) = \$$i\($k\)\""`
48			`}`
49			`}`
50			`}`
51			`]`
52			`}`
53			`#`
54			`# Dump the body of procedures specified by a regexp.`
55			`#`
56			`proc dumprocs { args } {`
57			`foreach i [info procs $args] {`
58			`puts "\nproc $i \{ [info args $i] \} \{ [info body $i]\}"`
59			`}`
60			`}`
61
62			`#`
63			`# Dump all the current watchpoints`
64			`#`
65			`proc dumpwatch { args } {`
66			`foreach i [uplevel 1 "info vars $args"] {`
67			`set tmp ""`
68			`if { [catch "uplevel 1 array name $i" names] } {`
69			`set tmp [uplevel 1 trace vinfo $i]`
70			`if ![string match "" $tmp] {`
71			`puts "$i $tmp"`
72			`}`
73			`} else {`
74			`foreach k $names {`
75			`set tmp [uplevel 1 trace vinfo [set i]($k)]`
76			`if ![string match "" $tmp] {`
77			`puts "[set i]($k) = $tmp"`
78			`}`
79			`}`
80			`}`
81			`}`
82			`}`
83
84			`#`
85			`# Trap a watchpoint for an array`
86			`#`
87			`proc watcharray { element type} {`
88			`upvar [set array]($element) avar`
89			`case $type {`
90			`"w" { puts "New value of [set array]($element) is $avar" }`
91			`"r" { puts "[set array]($element) (= $avar) was just read" }`
92			`"u" { puts "[set array]($element) (= $avar) was just unset" }`
93			`}`
94			`}`
95
96			`proc watchvar { v type } {`
97			`upvar $v var`
98			`case $type {`
99			`"w" { puts "New value of $v is $var" }`
100			`"r" { puts "$v (=$var) was just read" }`
101			`"u" { puts "$v (=$var) was just unset" }`
102			`}`
103			`}`
104
105			`#`
106			`# Watch when a variable is written`
107			`#`
108			`proc watchunset { arg } {`
109			`if { [catch "uplevel 1 array name $arg" names ] } {`
110			`if ![uplevel 1 info exists $arg] {`
111			`puts stderr "$arg does not exist"`
112			`return`
113			`}`
114			`uplevel 1 trace variable $arg u watchvar`
115			`} else {`
116			`foreach k $names {`
117			`if ![uplevel 1 info exists $arg] {`
118			`puts stderr "$arg does not exist"`
119			`return`
120			`}`
121			`uplevel 1 trace variable [set arg]($k) u watcharray`
122			`}`
123			`}`
124			`}`
125
126			`#`
127			`# Watch when a variable is written`
128			`#`
129			`proc watchwrite { arg } {`
130			`if { [catch "uplevel 1 array name $arg" names ] } {`
131			`if ![uplevel 1 info exists $arg] {`
132			`puts stderr "$arg does not exist"`
133			`return`
134			`}`
135			`uplevel 1 trace variable $arg w watchvar`
136			`} else {`
137			`foreach k $names {`
138			`if ![uplevel 1 info exists $arg] {`
139			`puts stderr "$arg does not exist"`
140			`return`
141			`}`
142			`uplevel 1 trace variable [set arg]($k) w watcharray`
143			`}`
144			`}`
145			`}`
146
147			`#`
148			`# Watch when a variable is read`
149			`#`
150			`proc watchread { arg } {`
151			`if { [catch "uplevel 1 array name $arg" names ] } {`
152			`if ![uplevel 1 info exists $arg] {`
153			`puts stderr "$arg does not exist"`
154			`return`
155			`}`
156			`uplevel 1 trace variable $arg r watchvar`
157			`} else {`
158			`foreach k $names {`
159			`if ![uplevel 1 info exists $arg] {`
160			`puts stderr "$arg does not exist"`
161			`return`
162			`}`
163			`uplevel 1 trace variable [set arg]($k) r watcharray`
164			`}`
165			`}`
166			`}`
167
168			`#`
169			`# Delete a watch point`
170			`#`
171			`proc watchdel { args } {`
172			`foreach i [uplevel 1 "info vars $args"] {`
173			`set tmp ""`
174			`if { [catch "uplevel 1 array name $i" names] } {`
175			`catch "uplevel 1 trace vdelete $i w watchvar"`
176			`catch "uplevel 1 trace vdelete $i r watchvar"`
177			`catch "uplevel 1 trace vdelete $i u watchvar"`
178			`} else {`
179			`foreach k $names {`
180			`catch "uplevel 1 trace vdelete [set i]($k) w watcharray"`
181			`catch "uplevel 1 trace vdelete [set i]($k) r watcharray"`
182			`catch "uplevel 1 trace vdelete [set i]($k) u watcharray"`
183			`}`
184			`}`
185			`}`
186			`}`
187
188			`#`
189			`# This file creates GDB style commands for the Tcl debugger`
190			`#`
191			`proc print { var } {`
192			`puts "$var"`
193			`}`
194
195			`proc quit { } {`
196			`log_and_exit;`
197			`}`
198
199			`proc bt { } {`
200			`puts "[w]"`
201			`}`
202
203			`#`
204			`# create some stub procedures since we can't alias the command names`
205			`#`
206			`proc dp { args } {`
207			`uplevel 1 dumprocs $args`
208			`}`
209
210			`proc dv { args } {`
211			`uplevel 1 dumpvars $args`
212			`}`
213
214			`proc dl { args } {`
215			`uplevel 1 dumplocals $args`
216			`}`
217
218			`proc dw { args } {`
219			`uplevel 1 dumpwatch $args`
220			`}`
221
222			`proc q { } {`
223			`quit`
224			`}`
225
226			`proc p { args } {`
227			`uplevel 1 print $args`
228			`}`
229
230			`proc wu { args } {`
231			`uplevel 1 watchunset $args`
232			`}`
233
234			`proc ww { args } {`
235			`uplevel 1 watchwrite $args`
236			`}`
237
238			`proc wr { args } {`
239			`uplevel 1 watchread $args`
240			`}`
241
242			`proc wd { args } {`
243			`uplevel 1 watchdel $args`
244			`}`