~ chicken-core (chicken-5) /feathers.tcl
Trap1#!/usr/bin/env wish2#3# a graphical debugger for compiled CHICKEN programs4#5# Copyright (c) 2015-2022, The CHICKEN Team6# All rights reserved.7#8# Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following9# conditions are met:10#11# Redistributions of source code must retain the above copyright notice, this list of conditions and the following12# disclaimer.13# Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following14# disclaimer in the documentation and/or other materials provided with the distribution.15# Neither the name of the author nor the names of its contributors may be used to endorse or promote16# products derived from this software without specific prior written permission.17#18# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS19# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY20# AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR21# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR22# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR23# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY24# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR25# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE26# POSSIBILITY OF SUCH DAMAGE.272829set version 030set protocol_version 131set debugger_port 99993233set events(1) call34set events(2) assign35set events(3) gc36set events(4) entry37set events(5) signal38set events(6) connect39set events(7) listen40set events(8) interrupted4142set reply(SETMASK) 143set reply(TERMINATE) 244set reply(CONTINUE) 345set reply(SET_BREAKPOINT) 446set reply(CLEAR_BREAKPOINT) 547set reply(LIST_EVENTS) 648set reply(GET_BYTES) 749set reply(GET_AV) 850set reply(GET_SLOTS) 951set reply(GET_GLOBAL) 1052set reply(GET_STATS) 1153set reply(GET_TRACE) 125455set colors(header_foreground) white56set colors(header_background) black57set colors(text_foreground) black58set colors(text_background) gray9059set colors(event_foreground) black60set colors(event_background) white61set colors(breakpoint_foreground) white62set colors(breakpoint_background) DarkRed63set colors(highlight_foreground) white64set colors(highlight_background) CornflowerBlue65set colors(mark_foreground) black66set colors(mark_background) yellow67set colors(trace_background) gray9068set colors(trace_foreground) black6970set typecode(0) VECTOR71set typecode(1) SYMBOL72set typecode(66) STRING73set typecode(3) PAIR74set typecode(36) CLOSURE75set typecode(85) FLONUM76set typecode(39) PORT77set typecode(8) STRUCTURE78set typecode(41) POINTER79set typecode(42) LOCATIVE80set typecode(43) TAGGED_POINTER81set typecode(77) LAMBDA_INFO82set typecode(15) BUCKET8384set EXEC_EVENT_MASK 32; # signal85set STEP_EVENT_MASK 54; # call, entry, assign, signal8687set membar_height 5088set value_cutoff_limit 200; # must be lower than limit in dbg-stub.c8990set the_name "feathers"91set header_text "$the_name - (c)MMXV The CHICKEN Team - Version $version"92set startup_file ".$the_name"9394set client_addr ""95set client_file ""96set current_filename ""97set current_c_filename ""98set file_list {}99set bp_queue {}100set watched_queue {}101set value_queue {}102set current_line ""103set current_c_line ""104set current_bp_lines {}105set current_bp_globals {}106set font_name "Courier"107set font_size 12108set program_name ""109set search_path {"."}110set data_view ""111set c_view ""112set data_queue {}113set reply_queue {}114set starting_up 1115set stepping 0116set terminated 0117set arguments_item_id ""118set watched_variables {}119set current_variable ""120set current_value ""121set listening 0122set process_id 0123set statistics_data ""124set mark_start_index(.t) ""125set mark_start_index(.code.t) ""126set current_c_location ""127set last_marked_widget .t128set selected_filename ""129set trace_data ""130set last_location ""131set logging 0132133set env(CHICKEN_DEBUGGER) "localhost:9999"134135136proc Log {msg} {137 global logging138139 if {$logging} {puts stderr $msg}140}141142143proc SetupGUI {} {144 global font_name font_size colors the_name selected_filename145 label .h -height 1 -textvariable header_text -anchor w146 scrollbar .s -command {.t yview}147 text .t -wrap char -yscrollcommand {.s set} -cursor arrow -state disabled \148 -font [list $font_name $font_size]149 frame .f150 ttk::combobox .files -postcommand FilesList -textvariable selected_filename151 pack .h -side top -fill x152 pack .files -side top -fill x153 pack .f -side bottom -fill x154 pack .s -fill y -side right155 pack .t -fill both -expand 1156157 for {set i 1} {$i <= 10} {incr i} {158 button .f.b$i -text "F$i" -font {Helvetica 10} -borderwidth 0 -relief flat \159 -pady 0160 pack .f.b$i -side left -expand 1 -fill x161 }162163 .f.b1 configure -text "F1 Run"164 .f.b2 configure -text "F2 Where"165 .f.b3 configure -text "F3 AddDir"166 .f.b4 configure -text "F4 Data"167 .f.b5 configure -text "F5 Continue"168 .f.b6 configure -text "F6 Step"169 .f.b7 configure -text "F7 Find Prev"170 .f.b8 configure -text "F8 Find Next"171 .f.b9 configure -text "F9 C"172 .f.b10 configure -text "F10 Exit"173 .h configure -background $colors(header_background) \174 -foreground $colors(header_foreground) -font {Helvetica 12} \175 -borderwidth 0176 .t configure -background $colors(text_background) \177 -foreground $colors(text_foreground) \178 -insertbackground $colors(text_foreground) -borderwidth 0179180 .t tag configure ev -background $colors(event_background) \181 -foreground $colors(event_foreground)182 .t tag configure bp -background $colors(breakpoint_background) \183 -foreground $colors(breakpoint_foreground)184 .t tag configure hl -background $colors(highlight_background) \185 -foreground $colors(highlight_foreground)186 .t tag configure mk -background $colors(mark_background) \187 -foreground $colors(mark_foreground)188 .t tag lower mk sel189 .t tag lower bp mk190 .t tag lower hl bp191 .t tag lower ev hl192 focus .t193 wm title . $the_name194}195196197proc SetupBindings {} {198 for {set i 1} {$i <= 10} {incr i} {199 bind . <F$i> [list .f.b$i invoke]200 }201202 .f.b1 configure -command RunProcess203 .f.b2 configure -command LocateFocus204 .f.b3 configure -command AddDirectory205 .f.b4 configure -command ShowData206 .f.b5 configure -command ContinueExecution207 .f.b6 configure -command StepExecution208 .f.b7 configure -command FindPrevious209 .f.b8 configure -command FindNext210 .f.b9 configure -command OpenCView211 .f.b10 configure -command Terminate212 bind .t <ButtonPress-1> { focus .t; ToggleBreakpoint %y; break }213 bind .t <ButtonRelease-1> break214 bind .t <space> {StepExecution; break}215 bind .t <Return> {ToggleBreakpoint; break}216 bind .t <Up> {MoveFocus -1; break}217 bind .t <Down> {MoveFocus 1; break}218 bind .t <plus> {ResizeFont 1; break}219 bind .t <minus> {ResizeFont -1; break}220 bind .t <Escape> {Interrupt}221 bind .t <ButtonPress-3> {StartMark %W %x %y; break}222 bind .t <Motion> {MoveMark %W %x %y; break}223 bind .t <ButtonRelease-3> {EndMark %W; break}224 bind .files <<ComboboxSelected>> {SelectFile; focus .t}225 wm protocol . WM_DELETE_WINDOW Terminate226}227228229proc SetupDataView {} {230 global colors arguments_item_id stats membar_height the_name font_name font_size231 toplevel .data232 ttk::treeview .data.t -yscrollcommand {.data.s set} -columns {Values Addresses} \233 -selectmode browse234 .data.t heading 0 -text Value235 .data.t heading 1 -text Address236 scrollbar .data.s -command {.data.t yview}237 entry .data.e238 canvas .data.c -height $membar_height239 frame .data.f240 text .data.f.tr -state disabled -yscrollcommand {.data.f.trs set} -height 20 \241 -font [list $font_name $font_size] -foreground $colors(trace_foreground) \242 -background $colors(trace_background)243 scrollbar .data.f.trs -command {.data.f.tr yview}244 pack .data.f -side bottom -fill x245 pack .data.c -side bottom -fill x246 pack .data.e -side bottom -fill x247 pack .data.s -fill y -side right248 pack .data.t -fill both -expand 1249 pack .data.f.trs -fill y -side right250 pack .data.f.tr -side bottom -fill both -expand 1251 .data.t tag configure watched -foreground $colors(breakpoint_foreground) \252 -background $colors(breakpoint_background)253 set arguments_item_id [.data.t insert {} end -text "<arguments>"]254 set stats(fromspace_used) [.data.c create rectangle 0 0 0 0 -fill gray80]255 set stats(fromspace_unused) [.data.c create rectangle 0 0 0 0 -fill gray40]256 set stats(scratchspace_used) [.data.c create rectangle 0 0 0 0 -fill gray80]257 set stats(scratchspace_unused) [.data.c create rectangle 0 0 0 0 -fill gray40]258 set stats(nursery_used) [.data.c create rectangle 0 0 0 0 -fill gray80]259 set stats(nursery_unused) [.data.c create rectangle 0 0 0 0 -fill gray40]260 set mh [expr $membar_height / 3]261 set stats(fromspace_name) [.data.c create text 10 0 -anchor nw -text "heap"]262 set stats(scratchspace_name) [.data.c create text 10 $mh -anchor nw -text \263 "scratch"]264 set stats(nursery_name) [.data.c create text 10 [expr $mh * 2] -anchor nw \265 -text "nursery"]266 set stats(fromspace_percentage) [.data.c create text 0 0 -anchor center]267 set stats(scratchspace_percentage) [.data.c create text 0 0 -anchor center]268 set stats(nursery_percentage) [.data.c create text 0 0 -anchor center]269 set stats(fromspace_size) [.data.c create text 0 0 -anchor ne]270 set stats(scratchspace_size) [.data.c create text 0 0 -anchor ne]271 set stats(nursery_size) [.data.c create text 0 0 -anchor ne]272 wm title .data "$the_name - data view"273}274275276proc SetupDataViewBindings {} {277 bind .data <F3> AddDirectory278 bind .data <F4> ShowData279 bind .data <F5> ContinueExecution280 bind .data <F6> StepExecution281 bind .data <F10> Terminate282 bind .data.e <Return> {WatchGlobal; break}283 bind .data.t <BackSpace> {RemoveGlobal; break}284 bind .data.t <Delete> {RemoveGlobal; break}285 bind .data.t <<TreeviewOpen>> OpenDataItem286 bind .data.t <Return> {ToggleVariableWatch; break}287 bind .data.t <Double-Button-1> {ToggleVariableWatch %x %y; break}288 bind .data.t <<TreeviewSelect>> {Log [.data.t focus]; break}289 bind .data.c <Configure> {RedrawStatistics}290 wm protocol .data WM_DELETE_WINDOW CloseDataView291}292293294proc SetupCView {} {295 global font_name font_size colors the_name296 toplevel .code297 label .code.h -height 1 -text "" -anchor w298 scrollbar .code.s -command {.code.t yview}299 text .code.t -wrap char -yscrollcommand {.code.s set} -cursor arrow -state \300 disabled -font [list $font_name $font_size]301 frame .code.f302 pack .code.h -side top -fill x303 pack .code.s -fill y -side right304 pack .code.f -fill x -side bottom305 pack .code.t -fill both -expand 1306 .code.h configure -background $colors(header_background) \307 -foreground $colors(header_foreground) -font {Helvetica 12} \308 -borderwidth 0309 .code.t configure -background $colors(text_background) \310 -foreground $colors(text_foreground) \311 -insertbackground $colors(text_foreground) -borderwidth 0312 .code.t tag configure hl -background $colors(highlight_background) \313 -foreground $colors(highlight_foreground)314 .code.t tag configure mk -background $colors(mark_background) \315 -foreground $colors(mark_foreground)316 .code.t tag lower mk sel317 .code.t tag lower hl mk318 wm title .code "$the_name - code view"319 focus .code.t320}321322323proc SetupCViewBindings {} {324 bind .code <F3> AddDirectory325 bind .code <F4> ShowData326 bind .code <F5> ContinueExecution327 bind .code <F6> StepExecution328 bind .code <F7> {FindPrevious .code.t}329 bind .code <F8> {FindNext .code.t}330 bind .code <F10> Terminate331 bind .code.t <ButtonPress-1> {focus .code.t}332 bind .code.t <ButtonRelease-1> break333 bind .code <plus> {ResizeFont 1; break}334 bind .code <minus> {ResizeFont -1; break}335 bind .code.t <ButtonPress-3> {StartMark %W %x %y; break}336 bind .code.t <Motion> {MoveMark %W %x %y; break}337 bind .code.t <ButtonRelease-3> {EndMark %W; break}338 wm protocol .code WM_DELETE_WINDOW CloseCView339}340341342proc FilesList {} {343 global file_list344 .files configure -values $file_list345}346347348proc CloseDataView {} {349 global data_view350351 if {$data_view != ""} {352 set data_view ""353 destroy .data354 }355}356357358proc CloseCView {} {359 global c_view360361 if {$c_view != ""} {362 set c_view ""363 destroy .code364 }365}366367368proc ShowData {} {369 global data_view starting_up client_file program_name the_name370371 if {$data_view == ""} {372 SetupDataView373 SetupDataViewBindings374 set data_view .data375 wm title .data "$the_name - $program_name - data view"376377 if {!$starting_up && $client_file != ""} UpdateData378 }379}380381382proc OpenCView {} {383 global c_view starting_up current_c_location the_name program_name384385 if {$c_view == ""} {386 SetupCView387 SetupCViewBindings388 set c_view .code389 wm title .code "$the_name - $program_name - code view"390391 Log "$current_c_location"392393 if {$current_c_location != ""} {394 LocateCSource $current_c_location395 }396 }397}398399400proc AddDirectory {} {401 global search_path current_filename402 set dir "."403404 if {$current_filename != ""} {405 set dir [file dirname $current_filename]406 }407408 set dir [tk_chooseDirectory -title "Select directory to add to search path" \409 -initialdir $dir]410411 if {$dir != ""} {412 lappend search_path $dir413 }414}415416417proc ResizeFont {n} {418 global font_size font_name c_view419 incr font_size $n420 .t configure -font [list $font_name $font_size]421422 if {$c_view != ""} {423 .code.t configure -font [list $font_name $font_size]424 }425}426427428proc Flash {{color red}} {429 global colors430 .t configure -background $color431 update432 after 100 {.t configure -background $colors(text_background)}433}434435436proc CheckListening {} {437 global listening438439 if {!$listening} {440 Flash441 return 0442 }443444 return 1445}446447448proc MoveFocus {amount} {449 global current_line450 set ln [expr $current_line + $amount]451 SetFocus $ln452}453454455proc LocateFocus {} {456 global last_location457458 if {$last_location != ""} {459 SetFocus $last_location460 }461}462463464proc SetFocus {line} {465 global current_line466467 if {$line > 0 && $line <= [.t count -lines 1.0 end]} {468 set old [.t tag ranges hl]469470 if {$old != ""} {471 eval .t tag remove hl $old472 }473474 set current_line $line475 .t tag add hl $line.0 "$line.0 lineend + 1 chars"476 .t see $line.0477 }478}479480481proc SetCFocus {line} {482 global current_c_line483484 if {$line > 0 && $line <= [.code.t count -lines 1.0 end]} {485 set old [.code.t tag ranges hl]486487 if {$old != ""} {488 eval .code.t tag remove hl $old489 }490491 set current_c_line $line492 .code.t tag add hl $line.0 "$line.0 lineend + 1 chars"493 .code.t see $line.0494 }495}496497498proc Interrupt {} {499 global process_id listening500501 if {$listening || $process_id == 0} return502503 catch {exec kill -USR2 $process_id}504}505506507proc ToggleBreakpoint {{y ""}} {508 global current_filename bp_queue current_bp_lines509 global current_line client_file reply_queue510511 if {$client_file == ""} return512513 if {$y != ""} {514 if {[catch {set p [.t index @1,$y]}]} return515516 if {![regexp {^(\d+)\.} $p _ line]} return517 } else {518 set line $current_line519 }520521 set aname "file:$current_filename"522 global $aname523 set aref "$aname\($line\)"524525 if {![CheckListening]} return526527 if {[info exists $aref]} {528 set bps [set $aref]529530 if {$bps != ""} {531 set bp1 [lindex $bps 0]532 set bprest [lrange $bps 1 end]533 set bp_queue [concat $bp_queue $bprest]534535 if {[lsearch -exact $current_bp_lines $line] != -1} {536 UnmarkBP $line537 SendReply CLEAR_BREAKPOINT $bp1538 lappend reply_queue RemoveBPReply539 } else {540 MarkBP $line541 SendReply SET_BREAKPOINT $bp1542 lappend reply_queue AddBPReply543 }544 }545 }546}547548549proc ToggleVariableWatch {{x ""} {y ""}} {550 global globals current_bp_globals bp_queue551552 if {![CheckListening]} return553554 if {$x == ""} {555 set item [.data.t focus]556 } else {557 if {[catch {.data.t identify item $x $y} item]} return558 }559560 if {$item == ""} return561562 if {[.data.t parent $item] != ""} return563564 set name [.data.t item $item -text]565566 if {$name == "<arguments>"} return567568 if {![info exists globals($name)]} return569570 Log "globals: $name -> $globals($name)"571572 set bps $globals($name)573574 if {$bps != ""} {575 set bp1 [lindex $bps 0]576 set bprest [lrange $bps 1 end]577 set bp_queue [concat $bp_queue $bprest]578579 if {[lsearch -exact $current_bp_globals $item] != -1} {580 UnmarkWatchedVariable $item581 SendReply CLEAR_BREAKPOINT $bp1582 lappend reply_queue RemoveBPReply583 } else {584 MarkWatchedVariable $item585 SendReply SET_BREAKPOINT $bp1586 lappend reply_queue AddBPReply587 }588 }589}590591592proc AddBPReply {} {593 global bp_queue reply_queue594595 if {$bp_queue != ""} {596 set bp1 [lindex $bp_queue 0]597 set bp_queue [lrange $bp_queue 1 end]598 SendReply SET_BREAKPOINT $bp1599600 if {$bp_queue != ""} {601 lappend reply_queue AddBPReply602 }603 }604}605606607proc RemoveBPReply {} {608 global bp_queue reply_queue609610 if {$bp_queue != ""} {611 set bp1 [lindex $bp_queue 0]612 set bp_queue [lrange $bp_queue 1 end]613 SendReply CLEAR_BREAKPOINT $bp1614615 if {$bp_queue != ""} {616 lappend reply_queue RemoveBPReply617 }618 }619}620621622proc MarkBP {line} {623 global current_bp_lines624625 if {[lsearch -exact $current_bp_lines $line] == -1} {626 .t tag add bp $line.0 "$line.0 lineend"627 lappend current_bp_lines $line628 }629}630631632proc UnmarkBP {line} {633 global current_bp_lines634 set i [lsearch -exact $current_bp_lines $line]635636 if {$i != -1} {637 set current_bp_lines [lreplace $current_bp_lines $i $i]638 .t tag remove bp $line.0 "$line.0 lineend"639 }640}641642643proc MarkWatchedVariable {item} {644 global current_bp_globals645646 if {[lsearch -exact $current_bp_globals $item] == -1} {647 .data.t tag add watched $item648 lappend current_bp_globals $item649 }650}651652653proc UnmarkWatchedVariable {item} {654 global current_bp_globals655 set i [lsearch -exact $current_bp_globals $item]656657 if {$i != -1} {658 set current_bp_globals [lreplace $current_bp_globals $i $i]659 .data.t tag remove watched $item660 }661}662663664proc Terminate {} {665 global client_file process_id666667 if {$client_file != ""} {668 SendReply TERMINATE669 set f $client_file670 set client_file ""671 close $f672 catch {exec kill -9 $process_id}673 }674675 exit676}677678679proc RunProcess {{prg ""}} {680 global env client_file program_name search_path reply_queue current_filename681 global data_queue bp_queue starting_up stepping terminated current_bp_lines682 global terminated watched_variables watched_queue listening file_list683 global value_queue process_id current_bp_globals data_view statistics_data684 global arguments_item_id trace_data last_location685686 if {$client_file != ""} {687 if {!$terminated} {SendReply TERMINATE}688689 set f $client_file690 set client_file ""691 close $f692 }693694 set program_name $prg695696 if {$program_name == ""} {697 set program_name [tk_getOpenFile -title "Select executable"]698 }699700 if {$program_name == ""} return701702 set args [lassign $program_name prgfname]703 set prgfname [file normalize $prgfname]704705 if {![file exists $prgfname]} {706 .t configure -state normal707 .t insert end "Could not start program:\n\nfile `$prgfname' does not exist"708 .t see end709 .t configure -state disabled710 }711712 lappend search_path [file dirname $prgfname]713 set reply_queue {}714 set data_queue {}715 set bp_queue {}716 set watched_queue {}717 set value_queue {}718 set last_location ""719 set starting_up 1720 set stepping 0721 set terminated 0722 set current_bp_lines {}723 set current_bp_globals {}724 set current_filename ""725 set watched_variables {}726 set listening 0727 set process_id 0728 set statistics_data ""729 set file_list {}730 set trace_data ""731 .t configure -state normal732 .t delete 1.0 end733 .t configure -state disabled734735 if {$data_view != ""} {736 .data.t delete [lrange [.data.t children {}] 1 end]737 .data.t delete [.data.t children $arguments_item_id]738 }739740 if {[catch {eval exec $prgfname {*}$args <@ stdin >@ stdout 2>@ stderr &} result]} {741 .t configure -state normal742 .t insert end "Could not start program:\n\n$result"743 .t see end744 .t configure -state disabled745 } else {746 set process_id $result747 }748}749750751proc UpdateHeader {{msg ""}} {752 global header_text current_filename client_addr current_line753 set header_text $client_addr754755 if {$current_filename != ""} {756 set header_text $current_filename757758 if {$current_line != ""} {759 append header_text ":$current_line"760 }761 }762763 if {$msg != ""} {764 append header_text " - $msg"765 }766}767768769proc ProcessInput {} {770 global client_file terminated771 gets $client_file line772773 if {[eof $client_file]} {774 close $client_file775 set client_file ""776 set terminated 1777 UpdateHeader "connection closed"778 } elseif {![fblocked $client_file]} {779 Log "Input: $line"780 ProcessLine $line781 }782}783784785proc ProcessLine {line} {786 if {[regexp {^\((\d+)\s+([^\s]*)\s+([^\s]*)\s+([^)]*)\)$} $line _ evt loc val cloc]} {787 set val [ProcessString $val]788 set loc [ProcessString $loc]789 set cloc [ProcessString $cloc]790 ProcessEvent $evt $loc $val $cloc791 } elseif {[regexp {^\(\*\s*(.*)\)$} $line _ data]} {792 ProcessData $data793 } else {794 UpdateHeader "invalid input: [string range $line 0 40]..."795 }796}797798799proc ProcessEvent {evt loc val cloc} {800 global events reply_queue starting_up EXEC_EVENT_MASK data_queue c_view801 global STEP_EVENT_MASK stepping data_view listening value_queue statistics_data802 global current_c_location protocol_version the_name program_name trace_data803804 set listening 1805806 if {[info exists events($evt)]} {807 set eventname $events($evt)808 } else {809 UpdateHeader "unrecognized event: $evt"810 return811 }812813 if {$data_queue != ""} {814 set data_queue [lrange $data_queue 1 end]815 }816817 Log "evt: $eventname, dq: $data_queue, rq: $reply_queue, vq: $value_queue"818819 if {$eventname != "listen"} {820 set statistics_data ""821 set trace_data ""822 }823824 set current_c_location $cloc825826 if {$c_view != ""} {827 LocateCSource $cloc828 }829830 switch $eventname {831 connect {832 if {![regexp {^([^:]+):([^:]+):(\d+)$} $loc _ name pid pv]} {833 UpdateHeader "invalid connection info: $loc"834 return835 }836837 if {$pv > $protocol_version} {838 UpdateHeader "client protocol doesn't match: $pv"839 return840 }841842 wm title . "$the_name - $program_name"843844 Log "\n##################### CONNECT ##################"845 SendReply SETMASK $STEP_EVENT_MASK846 set stepping 1847 lappend reply_queue FetchEventListReply FirstStepReply848 }849 listen {850 if {$reply_queue != ""} {851 set action [lindex $reply_queue 0]852 set reply_queue [lrange $reply_queue 1 end]853 Log "action: $action"854 $action855 } elseif {$val == 1} {856 # new dbg-info was registered857 lappend reply_queue ApplyTags858 FetchEventListReply859 }860 }861 default {862 # call/entry/assign/signal/gc863 LocateEvent $loc $val864 UpdateHeader "\[$eventname\]"865866 if {$starting_up} {867 SendReply SETMASK $EXEC_EVENT_MASK868 set starting_up 0869 } elseif {$data_view != ""} UpdateData870 }871 }872}873874875proc UpdateData {} {876 global data_queue reply_queue watched_variables877 global watched_queue878 set watched_queue $watched_variables879 lappend reply_queue GetGlobals880 lappend data_queue GetAVData881 SendReply GET_AV882}883884885proc GetAVData {data} {886 global arguments_item_id value_queue887 set vals [ParseValueList $data]888 set cs [.data.t children $arguments_item_id]889 set len [llength $vals]890 set clen [llength $cs]891892 for {set i 0} {$i < $len} {incr i} {893 lassign [ValueData [lindex $vals $i]] type text addr894895 if {$i >= $clen} {896 set c [.data.t insert $arguments_item_id end -text $type -values \897 [list $text $addr]]898 } else {899 set c [lindex $cs $i]900 .data.t item $c -text $type -values [list $text $addr]901 }902903 if {$addr != ""} {904 lappend value_queue $c905 }906907 incr i908 }909910 if {$i < $clen} {911 .data.t delete [lrange $cs $i end]912 }913914 .data.t item $arguments_item_id -open 1915}916917918proc GetGlobals {} {919 global data_queue reply_queue watched_queue current_variable920 global data_view value_queue921922 if {$watched_queue != ""} {923 set current_variable [lindex $watched_queue 0]924 set watched_queue [lrange $watched_queue 1 end]925 lappend data_queue GetGlobalData926 set name [MangleSymbol [.data.t item $current_variable -text]]927 SendReply GET_GLOBAL "\"$name\""928 lappend reply_queue GetGlobals929 } elseif {$data_view != ""} {930 if {$value_queue != ""} {931 GetValues932 } else {933 GetStatistics934 }935 }936}937938939proc GetValues {} {940 global data_view value_queue current_value data_queue reply_queue941942 if {$data_view != ""} {943 if {$value_queue != ""} {944 set current_value [lindex $value_queue 0]945 Log "get value: $current_value"946 set value_queue [lrange $value_queue 1 end]947 lappend data_queue GetValueData948 scan [.data.t set $current_value 1] %x addr949 SendReply GET_SLOTS $addr950 lappend reply_queue GetValues951 } else {952 UpdateValueText {}953 GetTrace954 }955 }956}957958959proc GetTrace {} {960 global data_queue trace_data reply_queue961962 if {$trace_data == ""} {963 lappend reply_queue GetStatistics964 lappend data_queue GetTraceData965 SendReply GET_TRACE966 } else GetStatistics967}968969970proc GetTraceData {data} {971 global trace_data972973 if {![regexp {^"([^"]*)"$} $data _ str]} {974 append trace_data "<invalid trace data>\n"975 } else {976 append trace_data "$str\n"977 }978}979980981proc RedrawTrace {} {982 global trace_data983 .data.f.tr configure -state normal984 .data.f.tr delete 1.0 end985 .data.f.tr insert 1.0 $trace_data986 .data.f.tr configure -state disabled987}988989990proc GetStatistics {} {991 global data_queue statistics_data reply_queue trace_data992993 if {$trace_data != ""} RedrawTrace994995 if {$statistics_data == ""} {996 lappend data_queue GetStatisticsData997 SendReply GET_STATS998 }999}100010011002proc GetStatisticsData {data} {1003 global statistics_data1004 set addrs [ParseValueList $data]1005 set statistics_data $addrs1006 RedrawStatistics1007}100810091010proc RedrawStatistics {} {1011 global statistics_data stats membar_height10121013 if {$statistics_data == ""} return10141015 set w [winfo width .data.c]1016 set w2 [expr $w / 2]1017 set w10 [expr $w - 10]1018 set mh [expr $membar_height / 3]1019 set mh2 [expr $mh * 2]10201021 # fromspace1022 lassign [CalcSize [lindex $statistics_data 0] [lindex $statistics_data 1] \1023 [lindex $statistics_data 6] $w] p pc sz1024 .data.c coords $stats(fromspace_used) 0 0 $p $mh1025 .data.c coords $stats(fromspace_unused) $p 0 $w $mh1026 .data.c coords $stats(fromspace_percentage) $w2 [expr $mh / 2]1027 .data.c itemconfigure $stats(fromspace_percentage) -text "$pc%"1028 .data.c coords $stats(fromspace_size) $w10 01029 .data.c itemconfigure $stats(fromspace_size) -text "${sz}k"10301031 # scratchspace1032 if {[lindex $statistics_data 2] != 0} {1033 lassign [CalcSize [lindex $statistics_data 2] [lindex $statistics_data 3] \1034 [lindex $statistics_data 7] $w] p pc sz1035 .data.c coords $stats(scratchspace_used) 0 $mh $p $mh21036 .data.c coords $stats(scratchspace_unused) $p $mh $w $mh21037 .data.c coords $stats(scratchspace_percentage) $w2 [expr int($mh * 1.5)]1038 .data.c itemconfigure $stats(scratchspace_percentage) -text "$pc%"1039 .data.c coords $stats(scratchspace_size) $w10 $mh1040 .data.c itemconfigure $stats(scratchspace_size) -text "${sz}k"1041 }10421043 # nursery1044 lassign [CalcSize [lindex $statistics_data 4] [lindex $statistics_data 5] \1045 [lindex $statistics_data 8] $w 1] p pc sz1046 .data.c coords $stats(nursery_used) 0 $mh2 $p $membar_height1047 .data.c coords $stats(nursery_unused) $p $mh2 $w $membar_height1048 .data.c coords $stats(nursery_percentage) $w2 [expr int($mh * 2.5)]1049 .data.c itemconfigure $stats(nursery_percentage) -text "$pc%"1050 .data.c coords $stats(nursery_size) $w10 $mh21051 .data.c itemconfigure $stats(nursery_size) -text "${sz}k"1052}105310541055proc CalcSize {start limit top width {inv 0}} {1056 set total [expr $limit - $start]10571058 if {$inv} {1059 set amount [expr $limit - $top]1060 } else {1061 set amount [expr $top - $start]1062 }10631064 set p [expr int(double($amount) / $total * 100)]1065 set sz [expr $total / 1024]1066 return [list [expr int((double($width) / $total) * $amount)] $p $sz]1067}106810691070proc GetValueData {data} {1071 global current_value value_queue typecode value_cutoff_limit10721073 set vals [ParseValueList $data]1074 set bits [lindex $vals 1]10751076 if {[info exists typecode($bits)]} {1077 set type $typecode($bits)1078 } else {1079 set type "<invalid: $bits>"1080 }10811082 .data.t item $current_value -text $type1083 set cs {}10841085 switch [lindex $vals 0] {1086 "SPECIAL" {1087 set cs [.data.t children $current_value]10881089 if {$cs == ""} {1090 set c1 [.data.t insert $current_value end]1091 set cs {}1092 } else {1093 set c1 [lindex $cs 0]1094 set cs [lrange $cs 1 end]1095 }10961097 .data.t item $c1 -text "<native pointer>" -values \1098 [list "" [format 0x%x [lindex $vals 2]]]1099 set vals [lrange $vals 3 end]1100 }1101 "VECTOR" {1102 set vals [lrange $vals 2 end]1103 set cs [.data.t children $current_value]1104 }1105 "BLOB" {1106 if {$type == "STRING" || $type == "LAMBDA_INFO"} {1107 set str "\""11081109 foreach c [lrange $vals 2 end] {1110 # XXX escape special chars1111 append str [format %c $c]1112 }11131114 append str "\""1115 } elseif {$type == "FLONUM"} {1116 set bytes [binary format c* $vals]1117 binary scan $bytes d str1118 } else {1119 set str "#\${"11201121 foreach c [lrange $vals 2 end] {1122 append str [format %02x $c]1123 }11241125 append str "}"1126 }11271128 .data.t set $current_value 0 $str1129 set cs [.data.t children $current_value]11301131 if {$cs != ""} {.data.t delete $cs}11321133 return1134 }1135 default {1136 UpdateHeader "invalid value: $data"1137 }1138 }11391140 set vlen [llength $vals]1141 set clen [llength $cs]11421143 for {set i 0} {$i < $vlen} {incr i} {1144 set val [lindex $vals $i]1145 lassign [ValueData $val] type text addr11461147 if {$i >= $clen} {1148 set c [.data.t insert $current_value end -text $type -values \1149 [list $text $addr]]1150 Log "insert: $c"1151 } else {1152 set c [lindex $cs $i]1153 Log "reuse: $c"1154 .data.t item $c -text $type -values [list $text $addr]1155 }11561157 if {$i >= $value_cutoff_limit} {1158 .data.t item $c -text ":" -values {"" ""}1159 incr i1160 break1161 }11621163 if {$addr != ""} {1164 if {[.data.t item [.data.t parent $c] -open]} {1165 lappend value_queue $c1166 }1167 } else {1168 .data.t delete [.data.t children $c]1169 }1170 }11711172 if {$i < $clen} {1173 .data.t delete [lrange $cs $i end]1174 }1175}117611771178proc UpdateValueText {node} {1179 global value_cutoff_limit1180 set cs [.data.t children $node]11811182 foreach c $cs {1183 UpdateValueText $c1184 }11851186 if {$node == ""} return11871188 set addr [.data.t set $node 1]11891190 if {$addr == ""} return11911192 set type [.data.t item $node -text]11931194 if {$type == ":"} return11951196 set str "..."11971198 switch $type {1199 "" return1200 "<arguments>" return1201 "<native pointer>" return1202 FLONUM return1203 LAMBDA_INFO return1204 STRING return1205 PAIR {1206 set car [.data.t set [lindex $cs 0] 0]1207 set cdr [.data.t set [lindex $cs 1] 0]1208 set str "($car"12091210 switch [.data.t item [lindex $cs 1] -text] {1211 NULL {append str ")"}1212 PAIR {append str " [string range $cdr 1 end]"}1213 default {append str " . $cdr)"}1214 }1215 }1216 VECTOR {1217 if {$cs == ""} {1218 set str "#()"1219 } else {1220 set x0 [.data.t set [lindex $cs 0] 0]1221 set str "#($x0"12221223 foreach c [lrange $cs 1 end] {1224 set x [.data.t set $c 0]1225 append str " $x"1226 }12271228 append str ")"1229 }1230 }1231 SYMBOL {1232 set name [.data.t set [lindex $cs 1] 0]1233 set str [DemangleSymbol [string range $name 1 "end-1"]]1234 }1235 default {1236 set str "#<$type $addr>"1237 }1238 }12391240 if {[string length $str] >= $value_cutoff_limit} {1241 set str "[string range $str 0 $value_cutoff_limit]..."1242 }12431244 .data.t set $node 0 $str1245}124612471248proc OpenDataItem {} {1249 global value_queue listening1250 set item [.data.t focus]12511252 if {$item == ""} return12531254 if {!$listening} return12551256 if {[.data.t parent $item] == ""} return12571258 set cs [.data.t children $item]12591260 foreach c $cs {1261 if {[.data.t set $c 1] != "" && \1262 [.data.t item $c -text] != "<native pointer>"} {1263 lappend value_queue $c1264 }1265 }12661267 GetValues1268}126912701271proc WatchGlobal {} {1272 global data_queue watched_variables current_variable reply_queue12731274 if {![CheckListening]} return12751276 set name [string trim [.data.e get]]1277 .data.e delete 0 end12781279 if {$name == ""} return12801281 if {[lsearch -exact $watched_variables $name] != -1} return12821283 set id [.data.t insert {} end -text $name]1284 lappend watched_variables $id1285 lappend data_queue GetGlobalData1286 set current_variable $id1287 set name [MangleSymbol $name]1288 SendReply GET_GLOBAL "\"$name\""1289 lappend reply_queue GetValues1290}129112921293proc RemoveGlobal {} {1294 global watched_variables arguments_item_id1295 set f [.data.t focus]12961297 if {$f == $arguments_item_id || [.data.t parent $f] == $arguments_item_id} return12981299 .data.t delete $f13001301 if {$f == ""} return13021303 set p [lsearch -exact $watched_variables $f]1304 set watched_variables [lreplace $watched_variables $p $p]1305}130613071308proc GetGlobalData {data} {1309 global current_variable watched_variables value_queue13101311 if {$data == "UNKNOWN"} {1312 .data.t set $current_variable 0 "UNKNOWN"1313 set p [lsearch -exact $watched_variables $current_variable]1314 set watched_variables [lreplace $watched_variables $p $p]1315 return1316 }13171318 set node [.data.t children $current_variable]13191320 if {$node == ""} {1321 set node [.data.t insert $current_variable end]1322 .data.t item $current_variable -open 11323 }13241325 set val [ParseValueList $data]1326 lassign [ValueData $val] type text addr1327 .data.t item $node -text $type1328 .data.t set $node 0 $text1329 .data.t set $node 1 $addr13301331 if {$addr != ""} {1332 lappend value_queue $node1333 }1334}133513361337# returns type, text and address1338proc ValueData {val} {1339 set c1 [string index $val 0]1340 set rest [string range $val 1 end]13411342 switch $c1 {1343 "@" {1344 return [list "" "..." [format "0x%x" $rest]]1345 }1346 "=" {1347 switch $rest {1348 6 {return {"BOOLEAN" "#f" ""}}1349 22 {return {"BOOLEAN" "#t" ""}}1350 14 {return {"NULL" "()" ""}}1351 30 {return {"UNDEFINED" "#<undefined>" ""}}1352 46 {return {"UNBOUND" "#<unbound>" ""}}1353 62 {return {"EOF" "#<eof>" ""}}1354 default {1355 if {($val & 15) == 10} {1356 return [list "CHARACTER" [format "#\%c" [expr $val >> 8]] ""]1357 }13581359 return [list "???" [format "#<unknown immediate value 0x%x>" \1360 $val] ""]1361 }1362 }1363 }1364 default {return [list "FIXNUM" $val ""]}1365 }1366}136713681369proc MangleSymbol {str} {1370 if {[regexp {^##([^#]+)#(.+)$} $str _ prefix name]} {1371 set len [string length $prefix]1372 return [binary format ca*a* $len $prefix $name]1373 }13741375 return $str1376}137713781379proc DemangleSymbol {str} {1380 set b1 ""1381 binary scan $str ca* b1 name13821383 if {$b1 == ""} {1384 return $str1385 } elseif {$b1 == 0} {1386 return "#:$name"1387 } elseif {$b1 < 32} {1388 return [format "##%s#%s" [string range $name 0 2] [string range $name 3 end]]1389 }13901391 return $str1392}139313941395proc ParseValueList {str} {1396 set vals {}13971398 while {[regexp {^\s*(\S+)(.*)$} $str _ val rest]} {1399 lappend vals $val1400 set str $rest1401 }14021403 return $vals1404}140514061407proc FirstStepReply {} {1408 global stepping1409 set stepping 01410 SendReply CONTINUE1411}141214131414proc ProcessData {data} {1415 global data_queue14161417 if {$data_queue == ""} {1418 UpdateHeader "unexpected data: $data"1419 }14201421 set handler [lindex $data_queue 0]1422 $handler $data1423}142414251426proc ExtractLocation args {1427 foreach data $args {1428 if {[regexp {^([^:]+):(\d+)(: .*)?$} $data _ fname line]} {1429 return [list $fname $line]1430 }1431 }14321433 return ""1434}143514361437proc LocateFile {fname} {1438 global search_path14391440 foreach d $search_path {1441 set fn [file join $d $fname]14421443 if {[file exists $fn]} {1444 set fn [file normalize $fn]1445 Log "Located: $fn"1446 return $fn1447 }1448 }14491450 return ""1451}145214531454proc InsertDebugInfo {index event args} {1455 global file_list globals1456 set loc [eval ExtractLocation $args]14571458 # check for assignment event1459 if {$event == 1} {1460 set name [lindex $args 1]1461 lappend globals($name) $index1462 }14631464 if {$loc != ""} {1465 set fname [LocateFile [lindex $loc 0]]14661467 if {[lsearch -exact $file_list $fname] == -1} {1468 lappend file_list $fname1469 }14701471 set line [lindex $loc 1]1472 # icky: compute array variable name from filename:1473 set tname "file:$fname"1474 global $tname1475 set xname "$tname\($line\)"1476 lappend $xname $index1477 return 11478 }14791480 return 01481}14821483proc ProcessString {str} {1484 if {$str == "#f"} {1485 return ""1486 } elseif {[regexp {^"(.*)"$} $str _ strip]} {1487 return $strip1488 } else {1489 return $str1490 }1491}14921493proc FetchEventListReply {} {1494 global file_list reply_queue data_queue1495 UpdateHeader "fetching debug information ..."1496 lappend data_queue EventInfoData1497 SendReply LIST_EVENTS {""}1498}149915001501proc EventInfoData {data} {1502 if {[regexp {(\d+)\s+(\d+)\s+([^\s]*)\s+(.*)$} $data _ index event loc val]} {1503 set loc [ProcessString $loc]1504 set val [ProcessString $val]1505 InsertDebugInfo $index $event $loc $val1506 } else {1507 UpdateHeader "invalid event data: $data"1508 }1509}151015111512proc ContinueExecution {} {1513 global client_file EXEC_EVENT_MASK stepping reply_queue listening1514 global value_queue15151516 if {$client_file == ""} return15171518 if {![CheckListening]} return15191520 UpdateHeader "executing ..."15211522 if {$stepping} {1523 set stepping 01524 SendReply SETMASK $EXEC_EVENT_MASK1525 lappend reply_queue ContinueExecution1526 } else {1527 set value_queue {}1528 set listening 01529 SendReply CONTINUE1530 }1531}153215331534proc StepExecution {} {1535 global STEP_EVENT_MASK client_file stepping listening value_queue reply_queue1536 global watched_queue15371538 if {$client_file == ""} return15391540 if {![CheckListening]} return15411542 if {!$stepping} {1543 set stepping 11544 SendReply SETMASK $STEP_EVENT_MASK1545 lappend reply_queue StepExecution1546 } else {1547 set value_queue {}1548 set watched_queue {}1549 set listening 01550 SendReply CONTINUE1551 }15521553 UpdateHeader "stepping ..."1554}155515561557proc StartMark {w x y} {1558 global mark_start_index last_marked_widget1559 set mark_start_index($w) ""1560 set last_marked_widget $w1561 set old [$w tag ranges mk]15621563 if {$old != ""} {1564 eval $w tag remove mk $old1565 }15661567 if {![catch {$w index "@$x,$y"} pos]} {1568 set mark_start_index($w) $pos1569 }1570}157115721573proc EndMark {w} {1574 global mark_start_index1575 set rng [$w tag ranges mk]15761577 if {$rng != ""} {1578 set text [eval $w get $rng]1579 set len [string length $text]1580 set found [$w search -all $text 1.0 end]15811582 foreach f $found {1583 $w tag add mk $f "$f + $len chars"1584 }1585 }15861587 set mark_start_index($w) ""1588}158915901591proc MoveMark {w x y} {1592 global mark_start_index15931594 if {$mark_start_index($w) == ""} return15951596 if {![catch {$w index "@$x,$y"} pos]} {1597 if {$pos == $mark_start_index($w)} return15981599 set old [$w tag ranges mk]16001601 if {$old != ""} {1602 eval $w tag remove $old1603 }16041605 if {[$w compare $pos < $mark_start_index($w)]} {1606 set tmp $mark_start_index($w)1607 set mark_start_index($w) $pos1608 set pos $tmp1609 }16101611 $w tag add mk $mark_start_index($w) $pos1612 }1613}161416151616proc FindNext {{w ""}} {1617 global last_marked_widget16181619 if {$w == ""} {set w $last_marked_widget}16201621 # not sure if this test is needed1622 if {[catch {$w index "@1,1"} pos]} return16231624 while 1 {1625 set rng [$w tag nextrange mk $pos end]16261627 if {$rng == ""} return16281629 lassign $rng p1 pos16301631 if {[$w dlineinfo $p1] == ""} {1632 $w see $p11633 return1634 }1635 }1636}163716381639proc FindPrevious {{w ""}} {1640 global last_marked_widget16411642 if {$w == ""} {set w $last_marked_widget}16431644 # not sure if this test is needed1645 if {[catch {$w index "@1,1"} pos]} return16461647 set rng [$w tag prevrange mk $pos 1.0]16481649 if {$rng == ""} return16501651 set p1 [lindex $rng 0]1652 $w see $p11653}165416551656proc SendReply {rep args} {1657 global client_file reply1658 set rest ""16591660 if {$args != ""} {1661 set rest " [join $args]"1662 }16631664 set str "($reply($rep)$rest)"1665 Log "send: $str"1666 puts $client_file $str1667}166816691670proc SelectFile {} {1671 global current_filename selected_filename16721673 if {$current_filename == $selected_filename} return16741675 if {![LoadFile $selected_filename]} return16761677 if {[SwitchFile $selected_filename]} ApplyTags1678}167916801681proc OpenFile {} {1682 global current_filename file_list1683 set dir "."16841685 if {$current_filename != ""} {1686 set dir [file dirname $current_filename]1687 }16881689 set fname [tk_getOpenFile -title "Select source file" -initialdir $dir]1690 set fname [file normalize $fname]16911692 if {$fname == "" || $fname == $current_filename} return16931694 if {[lsearch -exact $file_list $fname] == -1} {1695 tk_messageBox -message "No debug information available for \"$fname\"" \1696 -type ok1697 return1698 }16991700 if {![LoadFile $fname]} return17011702 if {[SwitchFile $fname]} ApplyTags1703}170417051706proc SwitchFile {fname} {1707 global current_bp_lines saved_bp_lines file_list current_filename17081709 Log "switch: $current_filename -> $fname"17101711 if {$current_filename != ""} {1712 Log "saving bps: $current_bp_lines"1713 set saved_bp_lines($current_filename) $current_bp_lines1714 }17151716 set current_filename $fname1717 Log "searching $fname in $file_list"17181719 if {[lsearch -exact $file_list $fname] != -1} {1720 if {[info exists saved_bp_lines($fname)]} {1721 set current_bp_lines {}1722 foreach line $saved_bp_lines($fname) {MarkBP $line}1723 Log "restoring bps: $current_bp_lines"1724 } else {1725 set current_bp_lines {}1726 }17271728 return 11729 }17301731 return 01732}173317341735proc LocateEvent {loc val} {1736 global current_filename file_list saved_bp_lines search_path last_location1737 set loc [ExtractLocation $loc $val]17381739 if {$loc != ""} {1740 set fname0 [lindex $loc 0]1741 set fname [LocateFile [lindex $loc 0]]1742 set line [lindex $loc 1]17431744 if {$fname != $current_filename} {1745 if {![LoadFile $fname]} return17461747 if {[SwitchFile $fname]} ApplyTags1748 }17491750 set last_location $line1751 SetFocus $line1752 }1753}175417551756proc LocateCSource {cloc} {1757 global current_c_filename search_path1758 set loc [ExtractLocation $cloc]17591760 if {$loc != ""} {1761 .code.h configure -text $cloc1762 set fname [file normalize [lindex $loc 0]]1763 set line [lindex $loc 1]17641765 if {$fname != $current_c_filename} {1766 foreach d $search_path {1767 set fn [file join $d $fname]17681769 if {[file exists $fn]} {1770 set fname $fn1771 break1772 }1773 }17741775 if {![LoadFile $fname .code.t]} return1776 }17771778 SetCFocus $line1779 }1780}178117821783proc LoadFile {fname {w .t}} {1784 $w configure -state normal1785 $w delete 1.0 end17861787 if {[file exists $fname]} {1788 set f [open $fname]1789 $w insert 1.0 [read $f]1790 close $f1791 $w configure -state disabled1792 return 11793 } else {1794 $w insert 1.0 "File not found: \"$fname\""1795 $w configure -state disabled1796 return 01797 }1798}179918001801proc ApplyTags {} {1802 global current_filename1803 set aname "file:$current_filename"1804 global $aname1805 set old [.t tag ranges ev]1806 Log "apply tags: $current_filename"18071808 if {$old != ""} {1809 eval .t tag remove $old1810 }18111812 foreach line [array names $aname] {1813 set evts [set $aname\($line\)]1814 .t tag add ev $line.0 "$line.0 lineend + 1 chars"1815 }18161817 UpdateHeader "events tagged"1818}181918201821proc Server {channel addr port} {1822 global client_addr client_file18231824 if {$client_file != ""} {1825 close $channel1826 return1827 }18281829 fconfigure $channel -buffering line -encoding binary -blocking 01830 fileevent $channel readable ProcessInput1831 set client_addr $addr1832 set client_file $channel1833}183418351836proc SetupServer {} {1837 global debugger_port1838 socket -server Server $debugger_port1839 .t configure -state normal1840 .t insert end "Waiting for connection from client ...\n"1841 .t configure -state disabled1842}184318441845proc Usage {code} {1846 global the_name1847 set usage "Usage: $the_name "1848 append usage {[-help] [-n] [-d] [-dir DIRNAME] [-port PORT] [PROGRAM ARGUMENTS ...]}1849 puts stderr $usage1850 exit $code1851}185218531854set load_startup_file 118551856for {set i 0} {$i < $argc} {incr i} {1857 set arg [lindex $argv $i]18581859 switch -regexp -- $arg {1860 {^--?(h|help)$} {Usage 0}1861 {^-dir$} {1862 incr i1863 lappend search_path [lindex $argv $i]1864 }1865 {^-n$} {set load_startup_file 0}1866 {^-port$} {1867 incr i1868 set debugger_port [lindex $argv $i]1869 }1870 {^-d$} {set logging 1}1871 {^-} {Usage 1}1872 default {1873 if {$program_name != ""} {Usage 0}18741875 set program_name [lrange $argv $i end]1876 break1877 }1878 }1879}188018811882if {$load_startup_file} {1883 if {[file exists $env(HOME)/$startup_file]} {1884 source $env(HOME)/$startup_file1885 }18861887 if {[file exists $startup_file]} {1888 source $startup_file1889 }1890}189118921893SetupGUI1894SetupBindings1895SetupServer18961897if {$program_name != ""} {1898 RunProcess $program_name1899}190019011902# TODO:1903#1904# - F2 is mostly pointless1905# - data-view update is slow1906# - modify only when necessary? or are we creating too many items on the fly?1907# - or too much TCP-traffic?1908# - allow spawning gdb, probably in separate terminal window(?)1909# - may be covered by just running "gdb <program>" as client1910# - setting breakpoints on yet unregistered (i.e. dynamically loaded) files1911# is not possible - a file must be registered first1912# - check whether "listening" check works1913# - when retrieved data is wrong, clear queues1914# - must watched globals be mangled, when qualified? (GET_GLOBAL)1915# - dview: monospace font (needs tags, it seems)1916# - https://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI.html#GDB_002fMI1917# - gdb interface:1918# - toggle bp in C-source line, step/execute1919# - needs a way to trigger gdb from running program (in dbg-stub.c)1920# (send signal to self (SIGUSR2?))1921# - allow explicit connection to debugger from Scheme code1922# - multiple dbg-info for identical filenames will cause havoc1923# - interrupt takes rather long (was in bignum-heavy code, try other)1924# - bignums are shown as raw strings (uses string-type for bitvec)1925# - how to handle threads?