/[ascend]/trunk/ascend4/TK/DebugProc.tcl
ViewVC logotype

Contents of /trunk/ascend4/TK/DebugProc.tcl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations) (download) (as text)
Fri Oct 29 20:54:12 2004 UTC (17 years, 6 months ago) by aw0a
File MIME type: text/x-tcl
File size: 26392 byte(s)
Setting up web subdirectory in repository
1 # DebugProc.tcl: Solver Debugger Tcl procedures
2 # by Benjamin A. Allan and Kirk A. Abbott
3 # Created: January 1994
4 # Part of ASCEND
5 # Revision: $Revision: 1.10 $
6 # Last modified on: $Date: 1998/06/18 15:54:41 $
7 # Last modified by: $Author: mthomas $
8 # Revision control file: $RCSfile: DebugProc.tcl,v $
9 #
10 # This file is part of the ASCEND Tcl/Tk Interface.
11 #
12 # Copyright (C) 1994-1998 Carnegie Mellon University
13 #
14 # The ASCEND Tcl/Tk Interface is free software; you can redistribute
15 # it and/or modify it under the terms of the GNU General Public
16 # License as published by the Free Software Foundation; either
17 # version 2 of the License, or (at your option) any later version.
18 #
19 # The ASCEND Tcl/Tk Interface is distributed in hope that it will be
20 # useful, but WITHOUT ANY WARRANTY; without even the implied warranty
21 # of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 # GNU General Public License for more details.
23 #
24 # You should have received a copy of the GNU General Public License
25 # along with the program; if not, write to the Free Software
26 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139 USA. Check the
27 # file named COPYING. COPYING is found in ../compiler.
28
29 #
30 # File structure:
31 # default set procedure
32 # button direct callbacks
33 # button internals
34 # utility routines
35 # routines that should be in other files
36 # re-sourceing this file while debugger up may lead to duplicate traces.
37 #
38 # set_Debug_Defaults {}
39 #----------------------------------------------------------------------------
40 # init vars for debugger window
41 #----------------------------------------------------------------------------
42 proc set_Debug_Defaults {} {
43 # puts "setting debugger buttons"
44 global ascDebuVect ascSolvVect
45 set ascDebuVect(eqncur) 0
46 set ascDebuVect(varcur) 0
47 set ascDebuVect(blkcur) 0
48 set ascDebuVect(eqnmax) 0
49 set ascDebuVect(varmax) 0
50 set ascDebuVect(blkmax) 0
51 set ascDebuVect(blksizes) "Rows:"
52 set ascDebuVect(visible) 1
53 set ascDebuVect(windowname) .debug
54 Debug_font_configure
55 }
56 proc Debug_font_configure {} {
57 global ascDebuVect ascSolvVect
58 if {[lsearch [font names] $ascDebuVect(font)] != -1} {
59 set fa [font actual $ascSolvVect(font)]
60 font configure $ascDebuVect(font) \
61 -family [lindex $fa 1] \
62 -size [lindex $fa 3] \
63 -weight [lindex $fa 5] \
64 -slant [lindex $fa 7] \
65 -underline [lindex $fa 9] \
66 -overstrike [lindex $fa 11]
67 }
68 }
69
70 #
71 # proc Debug_do_VarName {}
72 #----------------------------------------------------------------------------
73 # display focused variable name and value{dims} to stderr #
74 #----------------------------------------------------------------------------
75 proc Debug_do_VarName {} {
76 global ascDebuVect ascSolvVect
77 if {$ascDebuVect(varcur)!=""} {
78 dbg_write_var 1 $ascDebuVect(varcur) 2 0 [slv_get_pathname]
79 }
80 }
81
82 #
83 # proc Debug_do_VarAttr {}
84 #----------------------------------------------------------------------------
85 # display atomtype, dims, vaseetype, val, indexnum, qualified parent name, #
86 # and atom parts to stderr #
87 #----------------------------------------------------------------------------
88 proc Debug_do_VarAttr {} {
89 global ascDebuVect ascSolvVect
90 if {$ascDebuVect(varcur)!=""} {
91 puts [dbg_write_varattr $ascDebuVect(varcur)]
92 puts \n
93 }
94 }
95
96 #
97 # proc Debug_do_Var2Browser {}
98 #----------------------------------------------------------------------------
99 # export simulation and variable to browser. #
100 #----------------------------------------------------------------------------
101 proc Debug_do_Var2Browser {} {
102 global ascDebuVect ascSolvVect
103 if {$ascDebuVect(varcur)!=""} {
104 set tname [dbg_write_var 2 $ascDebuVect(varcur) 0 0]
105 regsub \{ $tname "" tname
106 regsub \} $tname "" tname
107 set tname [slv_get_pathname].$tname
108 Brow_Export_Any_2Browser $tname
109 }
110 }
111
112 #
113 # proc Debug_do_Var2Probe {}
114 #----------------------------------------------------------------------------
115 # export variable to probe. #
116 #----------------------------------------------------------------------------
117 proc Debug_do_Var2Probe {} {
118 global ascDebuVect ascSolvVect
119 if {$ascDebuVect(varcur)!=""} {
120 set tname [dbg_write_var 2 $ascDebuVect(varcur) 0 0]
121 regsub \{ $tname "" tname
122 regsub \} $tname "" tname
123 set tname [slv_get_pathname].$tname
124 PROBE ONE $tname
125 }
126 }
127
128 #
129 # proc Debug_do_EqnName {}
130 #----------------------------------------------------------------------------
131 # display focused eqn name and resid to stderr #
132 #----------------------------------------------------------------------------
133 proc Debug_do_EqnName {} {
134 global ascDebuVect ascSolvVect
135 if {$ascDebuVect(eqncur)!=""} {
136 dbg_write_rel 1 $ascDebuVect(eqncur) 2 [slv_get_pathname]
137 }
138 }
139 #
140 # proc Debug_do_EqnAttr {}
141 #----------------------------------------------------------------------------
142 # display relation indexnum, eqn as infix, residual, include flag to stderr #
143 #----------------------------------------------------------------------------
144 proc Debug_do_EqnAttr {} {
145 global ascDebuVect ascSolvVect
146 if {$ascDebuVect(eqncur)!=""} {
147 dbg_write_rel 1 $ascDebuVect(eqncur) 4
148 dbg_write_rel 1 $ascDebuVect(eqncur) 2 [slv_get_pathname]
149 }
150 }
151
152 #
153 # proc Debug_do_Eqn2Browser {}
154 #----------------------------------------------------------------------------
155 # export simulation and equation to browser. #
156 #----------------------------------------------------------------------------
157 proc Debug_do_Eqn2Browser {} {
158 global ascDebuVect ascSolvVect
159 if {$ascDebuVect(eqncur)!=""} {
160 set tname [dbg_write_rel 2 $ascDebuVect(eqncur) 0]
161 regsub \{ $tname "" tname
162 regsub \} $tname "" tname
163 set tname [slv_get_pathname].$tname
164 Brow_Export_Any_2Browser $tname
165 }
166 }
167
168 #
169 # proc Debug_do_Eqn2Probe {}
170 #----------------------------------------------------------------------------
171 # export equation to browser. #
172 #----------------------------------------------------------------------------
173 proc Debug_do_Eqn2Probe {} {
174 global ascDebuVect ascSolvVect
175 if {$ascDebuVect(eqncur)!=""} {
176 set tname [dbg_write_rel 2 $ascDebuVect(eqncur) 0]
177 regsub \{ $tname "" tname
178 regsub \} $tname "" tname
179 set tname [slv_get_pathname].$tname
180 PROBE ONE $tname
181 }
182 }
183
184 #
185 # proc Debug_do_BlkSize {} {
186 #----------------------------------------------------------------------------
187 # display block num of vars/rels to stderr #
188 # blocks of fixed variables generally have no relations #
189 #----------------------------------------------------------------------------
190 proc Debug_do_BlkSize {} {
191 global ascDebuVect
192 if {$ascDebuVect(blkcur) != ""} {
193 set part [dbg_get_varpartition]
194 set parts [split $part /]
195 set size [llength [lindex $parts $ascDebuVect(blkcur)]]
196 set ascDebuVect(blksizes) "Cols: $size"
197 # puts stderr "There are $size variables in block $ascDebuVect(blkcur)."
198 set part [dbg_get_eqnpartition]
199 set parts [split $part /]
200 set size [llength [lindex $parts $ascDebuVect(blkcur)]]
201 set ascDebuVect(blksizes) "Rows: $size $ascDebuVect(blksizes)"
202 # puts stderr "There are $size equations in block $ascDebuVect(blkcur)."
203 } else {
204 set ascDebuVect(blksizes) "Rows: 0 Cols: 0"
205 }
206 }
207
208 #
209 # proc Debug_do_BlkVarVal {}
210 #----------------------------------------------------------------------------
211 # name/val/dims of vars in block to stderr #
212 #----------------------------------------------------------------------------
213 proc Debug_do_BlkVarVal {} {
214 global ascDebuVect ascSolvVect
215 if {$ascDebuVect(blkcur)!=""} {
216 set part [dbg_get_varpartition]
217 set parts [split $part /]
218 set vars [lindex $parts $ascDebuVect(blkcur)]
219 set pname [slv_get_pathname]
220 foreach i $vars {dbg_write_var 1 $i 3 0 $pname}
221 }
222 }
223 #
224 # proc Debug_do_BlkVarAttr {}
225 #----------------------------------------------------------------------------
226 # display atomtype, dims, vaseetype, val, indexnum, qualified parent name, #
227 # and atom parts to stderr for all vars in block #
228 #----------------------------------------------------------------------------
229 proc Debug_do_BlkVarAttr {} {
230 global ascDebuVect ascSolvVect
231 if {$ascDebuVect(blkcur)!=""} {
232 set part [dbg_get_varpartition]
233 set parts [split $part /]
234 set vars [lindex $parts $ascDebuVect(blkcur)]
235 foreach i $vars {puts [dbg_write_varattr $i]\n}
236 }
237 }
238
239 #
240 # proc Debug_do_BlkVar2Probe {} {
241 #----------------------------------------------------------------------------
242 # export vars in block to probe #
243 #----------------------------------------------------------------------------
244 proc Debug_do_BlkVar2Probe {} {
245 global ascDebuVect ascSolvVect
246 if {$ascDebuVect(blkcur)!=""} {
247 set part [dbg_get_varpartition]
248 set parts [split $part /]
249 set vars [lindex $parts $ascDebuVect(blkcur)]
250 set pname [slv_get_pathname]
251 foreach i $vars {
252 set tname [lindex [dbg_write_var 2 $i 0 0] 0]
253 set tname $pname.$tname
254 PROBE current $tname
255 }
256 }
257 }
258 #
259 # proc Debug_do_BlkEqnResids {} {
260 #----------------------------------------------------------------------------
261 # display focused eqn name and resid to stderr for eqns in block #
262 #----------------------------------------------------------------------------
263 proc Debug_do_BlkEqnResids {} {
264 global ascDebuVect ascSolvVect
265 if {$ascDebuVect(blkcur)!=""} then {
266 set part [dbg_get_eqnpartition]
267 set parts [split $part /]
268 set rels [lindex $parts $ascDebuVect(blkcur)]
269 set pname [slv_get_pathname]
270 foreach i $rels {
271 dbg_write_rel 1 $i 2 $pname
272 }
273 }
274 return 0
275 }
276
277 #
278 # proc Debug_do_BlkEqnAttr {} {
279 #----------------------------------------------------------------------------
280 # display relation indexnum, eqn as infix, residual, include flag to stderr #
281 # for all equations in block #
282 #----------------------------------------------------------------------------
283 proc Debug_do_BlkEqnAttr {} {
284 global ascDebuVect ascSolvVect
285 if {$ascDebuVect(blkcur)!=""} {
286 set part [dbg_get_eqnpartition]
287 set parts [split $part /]
288 set rels [lindex $parts $ascDebuVect(blkcur)]
289 set pname [slv_get_pathname]
290 foreach i $rels {
291 puts stderr "-------------------- RELATION $i ------------------------"
292 dbg_write_rel 1 $i 2 $pname
293 dbg_write_rel 1 $i 4
294 }
295 }
296 }
297
298 #
299 # proc Debug_do_BlkEqnDep {} {
300 #----------------------------------------------------------------------------
301 # run numeric dependency check on block in focus #
302 #----------------------------------------------------------------------------
303 proc Debug_do_BlkEqnDep {} {
304 puts Debug_do_BlkEqnDep
305 }
306
307 #
308 # proc Debug_do_BlkEqn2Probe {} {
309 #----------------------------------------------------------------------------
310 # export eqns in block to probe #
311 #----------------------------------------------------------------------------
312 proc Debug_do_BlkEqn2Probe {} {
313 global ascDebuVect ascSolvVect
314 if {$ascDebuVect(blkcur)!=""} {
315 set part [dbg_get_eqnpartition]
316 set parts [split $part /]
317 set rels [lindex $parts $ascDebuVect(blkcur)]
318 set pname [slv_get_pathname]
319 foreach i $rels {
320 set tname [lindex [dbg_write_rel 2 $i 0] 0]
321 set tname $pname.$tname
322 PROBE current $tname
323 }
324 }
325 }
326 #
327 # proc Debug_do_Blk2Probe {} {
328 #----------------------------------------------------------------------------
329 # export eqns and vars in block to probe #
330 #----------------------------------------------------------------------------
331 proc Debug_do_Blk2Probe {} {
332 Debug_do_BlkEqn2Probe
333 Debug_do_BlkVar2Probe
334 }
335 #
336 # proc Debug_do_SysVarVal {} {
337 #----------------------------------------------------------------------------
338 # print free & incident var list to the screen #
339 #----------------------------------------------------------------------------
340 proc Debug_do_SysVarVal {} {
341 global ascDebuVect ascSolvVect
342 set vars [dbg_list_vars 5]
343 set pname [slv_get_pathname]
344 foreach i $vars {dbg_write_var 1 $i 3 0 $pname}
345 }
346 #
347 # proc Debug_do_SysVarAttr {} {
348 #----------------------------------------------------------------------------
349 # print attributes for all (partitioned) var list to the screen #
350 #----------------------------------------------------------------------------
351 proc Debug_do_SysVarAttr {} {
352 global ascDebuVect ascSolvVect
353 puts Debug_do_SysVarAttr
354 }
355
356 #
357 # proc Debug_do_SysVar2Nom {} {
358 #----------------------------------------------------------------------------
359 # Reset all free incident variables to their nominal values #
360 #----------------------------------------------------------------------------
361 proc Debug_do_SysVar2Nom {} {
362 global ascDebuVect ascSolvVect
363 puts stderr "Resetting all solver variables to their nominal values."
364 var_free2nom
365 HUB_Message_to_HUB VARIABLEUPDATED $ascSolvVect(simname)
366 }
367
368 #
369 # proc Debug_do_SysNom2Var {} {
370 #----------------------------------------------------------------------------
371 # Reset all free incident variable nominals to their var's current values #
372 #----------------------------------------------------------------------------
373 proc Debug_do_SysNom2Var {} {
374 global ascDebuVect ascSolvVect
375 puts stderr \
376 "Resetting all solver variable nominals to current variable values."
377 var_nom2free
378 HUB_Message_to_HUB VARIABLEUPDATED $ascSolvVect(simname)
379 }
380
381
382 #
383 # proc Debug_do_Sys2Probe {} {
384 #----------------------------------------------------------------------------
385 # export entire var list/eqn list of the instance to the probe #
386 # this isn't necessarily in solver index or master index order. it may
387 # coincidentally be in master index order.
388 #----------------------------------------------------------------------------
389 proc Debug_do_Sys2Probe {} {
390 global ascSolvVect
391 set pname [slv_get_pathname]
392 # reals, possibly not all solver_var.
393 PROBE current $pname {0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0}
394 # real relations
395 PROBE current $pname {1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}
396 # integers, possibly not all in whens
397 PROBE current $pname {0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0}
398 # booleans, possibly not all in whens
399 PROBE current $pname {0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0}
400 # logical relations
401 PROBE current $pname {0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0}
402 }
403 #
404 # proc Debug_do_OK {} {
405 #----------------------------------------------------------------------------
406 # close up the debugger #
407 #----------------------------------------------------------------------------
408 proc Debug_do_OK {} {
409 View_Save_SpecialWindow_Values debugger
410 Debug_Trace off
411 Solve_CloseDebugger
412 }
413
414 #
415 # proc Debug_do_Help {} {
416 #----------------------------------------------------------------------------
417 # run global help on the debugger #
418 #----------------------------------------------------------------------------
419 proc Debug_do_Help {} {
420 Debug_Help_Operations
421 }
422
423 #
424 # Debug_Help_Operations {}
425 #----------------------------------------------------------------------------
426 # help button for ascend debugger window
427 #----------------------------------------------------------------------------
428 proc Debug_Help_Operations {} {
429 puts "==================================================="
430 puts "Here are some of the C calls :"
431 dbghelp l
432 puts "==================================================="
433 puts "Here are some of the tcl calls :"
434 set tmp [info procs Debu*]
435 d_dumpproclist $tmp
436 puts "==================================================="
437 Help_button solver.debugger.intro
438
439 }
440
441 #
442 # proc Debug_Trace {state}
443 #----------------------------------------------------------------------------
444 # set debugger limits,traces for dialogue control #
445 # note that blocks, rels, vars are numbered 0 to max-1 in C #
446 #----------------------------------------------------------------------------
447 proc Debug_Trace {state} {
448 global ascSolvVect ascSolvStatVect ascDebuVect
449 set ascDebuVect(eqncur) ""
450 set ascDebuVect(varcur) ""
451 set ascDebuVect(blkcur) ""
452 set ascDebuVect(varlast) ""
453 set ascDebuVect(eqnlast) ""
454 set ascDebuVect(blklast) ""
455 # set traces if on, else unset traces, 0 maxima
456 if {$state == "on"} {
457 Solve_Update_StatVect
458 set ascDebuVect(eqnmax) $ascSolvStatVect(rels)
459 set ascDebuVect(varmax) $ascSolvStatVect(vars)
460 set ascDebuVect(blkmax) $ascSolvStatVect(block.number)
461 trace variable ascDebuVect(varcur) w Debug_Var_Trace
462 trace variable ascDebuVect(eqncur) w Debug_Eqn_Trace
463 trace variable ascDebuVect(blkcur) w Debug_Blk_Trace
464 } else {
465 set ascDebuVect(eqnmax) 0
466 set ascDebuVect(varmax) 0
467 set ascDebuVect(blkmax) 0
468 trace vdelete ascDebuVect(varcur) w Debug_Var_Trace
469 trace vdelete ascDebuVect(eqncur) w Debug_Eqn_Trace
470 trace vdelete ascDebuVect(blkcur) w Debug_Blk_Trace
471 }
472 }
473
474 #
475 # Debug_Blk_Trace {n1 n2 mode}
476 #----------------------------------------------------------------------------
477 # trace action for the Block entry. called on blkcur write #
478 #----------------------------------------------------------------------------
479 proc Debug_Blk_Trace {n1 n2 mode} {
480 global ascDebuVect
481 # puts stderr "Debug_Blk_Trace called."
482 Debug_do_BlkSize
483 if {[focus] == ".debug.entry_blk"} {
484 set ascDebuVect(eqncur) ""
485 set ascDebuVect(varcur) ""
486 set ascDebuVect(varlast) ""
487 set ascDebuVect(eqnlast) ""
488 if {[scan $ascDebuVect(blkcur) %d tmpcur] == "1"} {
489 if {$tmpcur<0 || $tmpcur >= $ascDebuVect(blkmax)} {
490 puts stderr "!!Block specified not within system!!"
491 set ascDebuVect(blkcur) $ascDebuVect(blklast)
492 } else {
493 .debug.entry_blk delete 0 end
494 .debug.entry_blk insert 0 $tmpcur
495 set ascDebuVect(blkcur) $tmpcur
496 set ascDebuVect(blklast) $tmpcur
497 }
498 } else {
499 if {$ascDebuVect(blkcur)==""} {
500 set ascDebuVect(eqnlast) ""
501 } else {
502 puts stderr "!!Illegal block specification!!"
503 set ascDebuVect(blkcur) $ascDebuVect(blklast)
504 }
505 }
506 }
507 }
508 #
509 # Debug_Eqn_Trace {n1 n2 mode}
510 #----------------------------------------------------------------------------
511 # trace action for the eqn entry. called on eqncur write #
512 #----------------------------------------------------------------------------
513 proc Debug_Eqn_Trace {n1 n2 mode} {
514 global ascDebuVect
515 # puts stderr "Debug_Eqn_Trace called"
516 if {[focus] == ".debug.entry_eqn"} {
517 set ascDebuVect(varcur) ""
518 set ascDebuVect(varlast) ""
519 if {[scan $ascDebuVect(eqncur) %d tmpcur] == "1"} {
520 if {$tmpcur <0 || $tmpcur >= $ascDebuVect(eqnmax)} {
521 puts stderr "!!Equation specified does not exist!!"
522 set ascDebuVect(eqncur) $ascDebuVect(eqnlast)
523 } else {
524 .debug.entry_eqn delete 0 end
525 .debug.entry_eqn insert 0 $tmpcur
526 set ascDebuVect(eqncur) $tmpcur
527 set ascDebuVect(eqnlast) $tmpcur
528 set tmpblk [ dbg_get_blk_of_eqn $tmpcur ]
529 if {$tmpblk == "none"} {
530 set ascDebuVect(blkcur) ""
531 # puts stderr "Equation specified is not assigned to a partition"
532 } else {
533 set ascDebuVect(blkcur) $tmpblk
534 }
535 set ascDebuVect(blklast) $ascDebuVect(blkcur)
536 }
537 } else {
538 if {$ascDebuVect(eqncur)==""} {
539 set ascDebuVect(eqnlast) ""
540 } else {
541 puts stderr "!!Illegal equation specification!!"
542 set ascDebuVect(eqncur) $ascDebuVect(eqnlast)
543 }
544 }
545 }
546 }
547
548 #
549 # Debug_Var_Trace {n1 n2 mode}
550 #----------------------------------------------------------------------------
551 # trace action for the var entry. called on varcur write #
552 #----------------------------------------------------------------------------
553 proc Debug_Var_Trace {n1 n2 mode} {
554 global ascDebuVect
555 if {[focus] == ".debug.entry_var"} {
556 if {[scan $ascDebuVect(varcur) %d tmpcur] == "1"} {
557 if {$tmpcur<0 || $tmpcur >= $ascDebuVect(varmax)} {
558 puts stderr "!!Variable specified does not exist!!"
559 set ascDebuVect(varcur) $ascDebuVect(varlast)
560 } else {
561 .debug.entry_var delete 0 end
562 .debug.entry_var insert 0 $tmpcur
563 set ascDebuVect(varcur) $tmpcur
564 set ascDebuVect(varlast) $tmpcur
565 # set tmpeqn [ dbg_get_eqn_of_var $tmpcur ]
566 # temporary patch to avoid crash. need to get linsol semantics
567 # from joe.
568 set tmpeqn none
569 set ascDebuVect(blkcur) ""
570 if {$tmpeqn == "none"} {
571 set ascDebuVect(eqncur) ""
572 } else {
573 set ascDebuVect(eqncur) $tmpeqn
574 }
575 set tmpblk [ dbg_get_blk_of_var $tmpcur ]
576 if {$tmpblk == "none"} {
577 set ascDebuVect(blkcur) ""
578 # puts stderr "Variable not assigned to a partition."
579 } else {
580 set ascDebuVect(blkcur) $tmpblk
581 }
582 set ascDebuVect(eqnlast) $ascDebuVect(eqncur)
583 set ascDebuVect(blklast) $ascDebuVect(blkcur)
584 }
585 } else {
586 if {$ascDebuVect(varcur)==""} {
587 set ascDebuVect(varlast) ""
588 } else {
589 puts stderr "!!Illegal variable specification!!"
590 set ascDebuVect(varcur) $ascDebuVect(varlast)
591 }
592 }
593 }
594 }
595
596 #
597 # proc uinfo {type} {
598 #----------------------------------------------------------------------------
599 # procedure to tell about various commands origins #
600 # assumes tcl/tk 7.1/3.4 and computes which user defined commands are #
601 # C calls and which are TCL procedures #
602 # excludes widget names (C calls starting with dots) from user C call list #
603 # all variables are set after the first call to unifo.
604 # bugs: fucking slow
605 # These 3 vars are lists of the predefined procedures, C calls, and both
606 # due to TCL
607 # global asctcl_procbase
608 # global asctcl_Cbase
609 # global asctcl_base
610 # These 3 vars are lists of the predefined procedures, C calls, and both
611 # due to TK
612 # global asctk_procbase
613 # global asctk_Cbase
614 # global asctk_base
615 # These 3 vars are lists of the predefined procedures, C calls, and both
616 # due to TCL+TK
617 # global asc_procbase
618 # global asc_Cbase
619 # global asc_base
620 # These 3 vars are lists of the predefined procedures, C calls, and both
621 # due to ASCEND. They are computed by this procedure.
622 # global asc_userproc
623 # global asc_userC
624 # global asc_user
625 # C calls that are widgets (starting with .) are segregated, though
626 # global asc_userwidgets
627 #----------------------------------------------------------------------------
628 proc uinfo {type} {
629 global asctcl_procbase
630 global asctcl_Cbase
631 global asctcl_base
632 global asctk_procbase
633 global asctk_Cbase
634 global asctk_base
635 global asc_procbase
636 global asc_Cbase
637 global asc_base
638 global asc_userproc
639 global asc_userC
640 global asc_user
641 global asc_userwidgets
642
643 set asctcl_procbase "unknown auto_execok auto_mkindex auto_reset auto_load"
644
645 set asctcl_Cbase [list \
646 tell open eof pwd glob list pid exec time eval lrange lsearch \
647 gets lappend proc break llength return linsert error catch info \
648 split array if concat join lreplace source global switch close for \
649 cd file append format read set scan trace seek while flush continue \
650 uplevel foreach rename regexp upvar expr unset regsub history exit \
651 puts incr lindex lsort string \
652 ]
653
654 set asctk_procbase [list \
655 tk_nextMenuEntry tk_bindForTraversal tk_menuBar tk_getMenuButtons \
656 tk_traverseToMenu tk_firstMenu tk_menus tk_invokeMenu tkMenuButtonDown \
657 tk_nextMenu tk_mbUnpost tk_traverseWithinMenu tk_mbPost 
658 ]
659
660 set asctk_Cbase [list menubutton listbox pack checkbutton canvas \
661 message place bind tkwait raise option toplevel update wm scale \
662 label focus radiobutton button lower destroy after winfo scrollbar \
663 grab menu . selection entry send frame text tk \
664 ]
665
666 set asctcl_base "$asctcl_procbase $asctcl_Cbase"
667 set asctk_base "$asctk_procbase $asctk_Cbase"
668
669 set asc_Cbase "$asctcl_Cbase $asctk_Cbase"
670 set asc_procbase "$asctcl_procbase $asctk_procbase"
671 set asc_base "$asc_procbase $asc_Cbase"
672
673 puts stderr "collecting widget names..."
674 set asc_userwidgets [info commands .*]
675
676 puts stderr "collecting user procedure names..."
677 set asc_proc [info procs]
678 set asc_userproc ""
679 foreach i $asc_proc {
680 if {[lsearch $asc_procbase $i]=="-1"} {
681 lappend asc_userproc $i
682 }
683 }
684 unset asc_proc
685
686 puts stderr "collecting user C call names..."
687 set asc_comm [info commands]
688 set asc_proc "$asc_userproc $asc_base $asc_userwidgets"
689 set asc_userC ""
690 foreach i $asc_comm {
691 if {[lsearch $asc_proc $i]=="-1"} {
692 lappend asc_userC $i
693 }
694 }
695
696 unset asc_comm
697 unset asc_proc
698
699 set asc_user "$asc_userC $asc_userproc"
700 switch $type {
701
702 {p} { puts "======= user defined TCL procedures ========"
703 puts $asc_userproc }
704 {c} { puts "======= user defined C calls ========"
705 puts $asc_userC }
706 {w} { puts "==== window names ===="
707 puts $asc_userwidgets }
708
709 {pa} { puts "==== user defined TCL procedures (alphabetizing) ===="
710 d_dumpproclist $asc_userproc }
711 {ca} { puts "==== user defined C calls (alphabetizing) ===="
712 d_dumplist $asc_userC }
713 {wa } { puts "==== window names (alphabetizing) ===="
714 d_dumplist $asc_userwidgets }
715 {help} {puts "uinfo sets the following global list variables:"
716 puts "(tcl/tk 7.1/3.4 assumed)"
717 puts "asctcl_procbase asctcl_Cbase asctcl_base"
718 puts "asctk_procbase asctk_Cbase asctk_base"
719 puts "asc_procbase asc_Cbase asc_base"
720 puts "asc_userproc asc_userC asc_user asc_userwidgets"
721 puts ""
722 puts "uinfo will list (and optionally alphabetize)"
723 puts \
724 "asc_userproc (p,pa) asc_userC (c,ca) asc_userwidgets (w,wa)."}
725 default {puts "global variables set. Call uinfo with: c,p,w,ca,pa,wa,help"}
726 }
727 }

john.pye@anu.edu.au
ViewVC Help
Powered by ViewVC 1.1.22