home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-bin / lib / dejagnu / debugger.exp < prev    next >
Encoding:
Text File  |  1996-10-12  |  5.0 KB  |  234 lines
  1. #   Copyright (C) 1988, 1990, 1991, 1992 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. # dumpvars -- 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. # dumprocs -- dump the body of procedures specified by a regexp.
  40. #
  41. proc dumprocs { args } {
  42.     foreach i [info procs $args] {
  43.     puts "\nproc $i \{ [info args $i] \} \{ [info body $i]\}"
  44.     }
  45. }
  46.  
  47. #
  48. # dumpwatch -- dump all the current watchpoints
  49. #
  50. proc dumpwatch { args } {
  51.     foreach i [uplevel 1 "info vars $args"] {
  52.     set tmp ""
  53.     if { [catch "uplevel 1 array name $i" names] } {
  54.         set tmp [uplevel 1 trace vinfo $i]
  55.         if ![string match "" $tmp] {
  56.         puts "$i $tmp"
  57.         }
  58.     } else {
  59.         foreach k $names {
  60.         set tmp [uplevel 1 trace vinfo [set i]($k)]
  61.         if ![string match "" $tmp] {
  62.             puts "[set i]($k) = $tmp"
  63.         }
  64.         }
  65.     }
  66.     }
  67. }
  68.  
  69. #
  70. # watcharray -- trap a watchpoint for an array
  71. #
  72. proc watcharray { array element type} {
  73.     upvar [set array]($element) avar
  74.     case $type {
  75.     "w" { puts "New value of [set array]($element) is $avar" }
  76.     "r" { puts "[set array]($element) (= $avar) was just read" }
  77.     "u" { puts "[set array]($element) (= $avar) was just unset" }
  78.     }
  79. }
  80.  
  81. proc watchvar { v null type } {
  82.     upvar $v var
  83.     case $type {
  84.     "w" { puts "New value of $v is $var" }
  85.     "r" { puts "$v (=$var) was just read" }
  86.     "u" { puts "$v (=$var) was just unset" }
  87.     }
  88. }
  89.  
  90. #
  91. # watchunset -- watch when a variable is written
  92. #
  93. proc watchunset { arg } {
  94.     if { [catch "uplevel 1 array name $arg" names ] } {
  95.     if ![uplevel 1 info exists $arg] {
  96.         puts stderr "$arg does not exist"
  97.         return
  98.     }
  99.     uplevel 1 trace variable $arg u watchvar
  100.     } else {
  101.     foreach k $names {
  102.         if ![uplevel 1 info exists $arg] {
  103.         puts stderr "$arg does not exist"
  104.         return
  105.         }
  106.         uplevel 1 trace variable [set arg]($k) u watcharray
  107.     }
  108.     }
  109. }
  110.  
  111. #
  112. # watchwrite -- watch when a variable is written
  113. #
  114. proc watchwrite { arg } {
  115.     if { [catch "uplevel 1 array name $arg" names ] } {
  116.     if ![uplevel 1 info exists $arg] {
  117.         puts stderr "$arg does not exist"
  118.         return
  119.     }
  120.     uplevel 1 trace variable $arg w watchvar
  121.     } else {
  122.     foreach k $names {
  123.         if ![uplevel 1 info exists $arg] {
  124.         puts stderr "$arg does not exist"
  125.         return
  126.         }
  127.         uplevel 1 trace variable [set arg]($k) w watcharray
  128.     }
  129.     }
  130. }
  131.  
  132. #
  133. # watchread -- watch when a variable is read
  134. #
  135. proc watchread { arg } {
  136.     if { [catch "uplevel 1 array name $arg" names ] } {
  137.     if ![uplevel 1 info exists $arg] {
  138.         puts stderr "$arg does not exist"
  139.         return
  140.     }
  141.     uplevel 1 trace variable $arg r watchvar
  142.     } else {
  143.     foreach k $names {
  144.         if ![uplevel 1 info exists $arg] {
  145.         puts stderr "$arg does not exist"
  146.         return
  147.         }
  148.         uplevel 1 trace variable [set arg]($k) r watcharray
  149.     }
  150.     }
  151. }
  152.  
  153. #
  154. # watchdel -- delete a watch point
  155. #
  156. proc watchdel { args } {
  157.     foreach i [uplevel 1 "info vars $args"] {
  158.     set tmp ""
  159.     if { [catch "uplevel 1 array name $i" names] } {
  160.         catch "uplevel 1 trace vdelete $i w watchvar"
  161.         catch "uplevel 1 trace vdelete $i r watchvar"
  162.         catch "uplevel 1 trace vdelete $i u watchvar"
  163.     } else {
  164.         foreach k $names {
  165.         catch "uplevel 1 trace vdelete [set i]($k) w watcharray"
  166.         catch "uplevel 1 trace vdelete [set i]($k) r watcharray"
  167.         catch "uplevel 1 trace vdelete [set i]($k) u watcharray"
  168.         }
  169.     }
  170.     }
  171. }
  172.  
  173. #
  174. # this file creates GDB style commands for the Tcl debugger
  175. #
  176. proc print { var } {
  177.     puts "$var"
  178. }
  179.  
  180. proc quit { } {
  181.     log_summary
  182.     exit
  183. }
  184.  
  185. proc bt { } {
  186.     puts "[w]"
  187. }
  188.  
  189. #
  190. # create some stub procedures since we can't alias the command names
  191. #
  192. proc dp { args } {
  193.   uplevel 1 dumprocs $args
  194. }
  195.  
  196. proc dv { args } {
  197.   uplevel 1 dumpvars $args
  198. }
  199.  
  200. proc dw { args } {
  201.     uplevel 1 dumpwatch $args
  202. }
  203.  
  204. proc q { } {
  205.     quit
  206. }
  207.  
  208. proc p { args } {
  209.     uplevel 1 print $args
  210. }
  211.  
  212. proc wu { args } {
  213.     uplevel 1 watchunset $args
  214. }
  215.  
  216. proc ww { args } {
  217.     uplevel 1 watchwrite $args
  218. }
  219.  
  220. proc wr { args } {
  221.     uplevel 1 watchread $args
  222. }
  223.  
  224. proc wd { args } {
  225.     uplevel 1 watchdel $args
  226. }
  227.  
  228.  
  229.  
  230.  
  231.  
  232.  
  233.  
  234.