563 lines
14 KiB
Tcl
563 lines
14 KiB
Tcl
#!/bin/sh
|
|
# Rildo Pragana -- Recife, 2001
|
|
#\
|
|
exec wish "$0" "$@"
|
|
|
|
# change the folowing to your cobol compile arguments
|
|
set gdb(cobol_args) "-D -I. -L../lib -L/usr/local/lib -ldb"
|
|
# set your compiler path here
|
|
set gdb(compiler_path) "../compiler"
|
|
# set list of lval casts to be chosen from
|
|
set gdb(cast_list) {
|
|
{struct sym *}
|
|
{int}
|
|
{struct lit *}
|
|
{unsigned long}
|
|
{char *}
|
|
{condition}
|
|
{struct vref *}
|
|
{struct refmod *}
|
|
{struct string_from *}
|
|
{struct unstring_delimited *}
|
|
{struct unstring_destinations *}
|
|
{struct tallying_list *}
|
|
{struct tallying_for_list *}
|
|
{struct replacing_list *}
|
|
{struct replacing_by_list *}
|
|
{struct inspect_before_after *}
|
|
{struct scr_info *}
|
|
{struct perf_info *}
|
|
{struct perform_info *}
|
|
{struct sortfile_node *}
|
|
{struct selsubject *}
|
|
{struct list *}
|
|
{struct coord_pair}
|
|
}
|
|
|
|
#####################################################
|
|
### please, don't touch anything below
|
|
|
|
option add *Scrollbar.width 10
|
|
option add *Scrollbar.borderWidth 1
|
|
|
|
set gdb(sourcefile) "tdb03.cob"
|
|
set gdb(asmfile) ""
|
|
set gdb(fd) -1
|
|
set history {step}
|
|
tcl_wordBreakAfter "Rildo Pragana" 0 ;# force loading package first
|
|
set tcl_wordchars {[a-zA-Z0-9_-]}
|
|
set tcl_nonwordchars {[^a-zA-Z0-9_-]}
|
|
|
|
### communication with gdb
|
|
proc gdbReceive {} {
|
|
global gdb
|
|
if {$gdb(ready)} {
|
|
set gdb(answer) ""
|
|
set gdb(ready) 0
|
|
}
|
|
set line [gets $gdb(fd)]
|
|
if {[string compare $line **READY**]} {
|
|
append gdb(answer) $line\n
|
|
} else {
|
|
incr gdb(ready)
|
|
}
|
|
puts "answer: $gdb(answer)"
|
|
}
|
|
|
|
proc sendgdb {cmd {wait 1}} {
|
|
global gdb
|
|
set gdb(answer) ""
|
|
set gdb(ready) 0
|
|
puts "gdb cmd: $cmd"
|
|
puts $gdb(fd) $cmd
|
|
if {$wait} {
|
|
while {!$gdb(ready)} {
|
|
update
|
|
}
|
|
}
|
|
}
|
|
|
|
proc ask_load_first {} {
|
|
tk_messageBox -message "Please load a source file first!"
|
|
}
|
|
|
|
proc load {} {
|
|
global gdb win
|
|
set gdb(sourcefile) [tk_getOpenFile \
|
|
-filetypes {{{Cobol source} .cob} {{All files} *}} \
|
|
-defaultextension cob]
|
|
if {$gdb(sourcefile) == ""} {
|
|
return
|
|
}
|
|
wm title . "Compiling $gdb(sourcefile)"
|
|
# locate breakpoints and create a list
|
|
set bkps {}
|
|
#set lines [split [exec grep -n 'yynewstate:|yybackup:|yyreduce:' \
|
|
# [file join $gdb(compiler_path) htcobol.tab.c]] \n]
|
|
|
|
set lines [split [exec grep -n {yystate[ \t]*=[ \t]*yyn.*} \
|
|
[file join $gdb(compiler_path) htcobol.tab.c]] \n]
|
|
|
|
foreach line $lines {
|
|
regexp {([0-9]+):.*} $line match bkp
|
|
lappend bkps $bkp
|
|
}
|
|
#puts $bkps
|
|
# prepare connection to gdb task
|
|
set gdb(asmfile) [file rootname $gdb(sourcefile)].s
|
|
set gdb(asmpos) 0
|
|
set gdb(tok) ""
|
|
set gdb(state) 0
|
|
set gdb(lineno) 1
|
|
set gdb(ready) 1
|
|
set gdb(fd) [open "|gdb -nx -q 2>@stdout" w+]
|
|
fconfigure $gdb(fd) -blocking 0 -buffering line
|
|
fileevent $gdb(fd) readable gdbReceive
|
|
sendgdb "set prompt **READY**\\n" 0
|
|
sendgdb "set confirm off" 1
|
|
sendgdb "set width 0" 1
|
|
sendgdb "file [file join $gdb(compiler_path) htcobol]" 1
|
|
sendgdb "set args $gdb(cobol_args) [file tail $gdb(sourcefile)]" 1
|
|
foreach bkp $bkps {
|
|
sendgdb "b htcobol.tab.c:$bkp" 1
|
|
}
|
|
sendgdb "r" 1
|
|
# load cobol source modified by the preprocessor
|
|
sendgdb "c" 1
|
|
$win(source) delete 0.0 end
|
|
#set inputname ""
|
|
set inputname $gdb(sourcefile)
|
|
#sendgdb "p input_filename" 1
|
|
#regexp {[^\"]*\"([^\"]*)\"} $gdb(answer) match inputname
|
|
set f [open $inputname r]
|
|
set n 0
|
|
while {![eof $f]} {
|
|
$win(source) insert end "[format %04d [incr n]]: [gets $f]\n"
|
|
}
|
|
close $f
|
|
# setup parser display variables
|
|
sendgdb "display source_lineno" 1
|
|
#sendgdb "display *yyssp" 1
|
|
sendgdb "display yystate" 1
|
|
sendgdb "display yytext" 1
|
|
.status.loaded config -bg red
|
|
}
|
|
|
|
### parse y.output file
|
|
|
|
proc parse_yacc_states {fname yname} {
|
|
global state action arule win
|
|
set f [open $yname r]
|
|
$win(grammar) delete 1.0 end
|
|
$win(grammar) insert end [read $f]
|
|
close $f
|
|
## read grammar rules table
|
|
set f [open $fname r]
|
|
while {1} {
|
|
gets $f line
|
|
if {[string trim $line] == "Grammar"} {
|
|
break
|
|
}
|
|
}
|
|
while {1} {
|
|
gets $f line
|
|
if {[regexp {[ \t]+([0-9]+)[ \t]+([0-9]+)[ \t]+.*} $line]} {
|
|
break
|
|
}
|
|
}
|
|
while {1} {
|
|
if {[regexp {[ \t]+([0-9]+)[ \t]+([0-9]+)[ \t]+.*} $line \
|
|
match rulen actn]} {
|
|
set arule($rulen) $actn
|
|
} else {
|
|
break
|
|
}
|
|
gets $f line
|
|
}
|
|
close $f
|
|
#puts [array get arule]
|
|
### create an indexed positions array for each line
|
|
set f [open $yname r]
|
|
set n 0
|
|
while {![eof $f]} {
|
|
set yline([incr n]) [tell $f]
|
|
gets $f
|
|
}
|
|
close $f
|
|
set f [open $yname r]
|
|
foreach {ix val} [array get arule] {
|
|
seek $f $yline($val)
|
|
gets $f line
|
|
while {[string first \{ $line] < 0} {
|
|
gets $f line1
|
|
append line \n$line1
|
|
}
|
|
set i [string first \{ $line]
|
|
set action($ix) [string range $line $i end]
|
|
while {![info complete $action($ix)]} {
|
|
gets $f line
|
|
append action($ix) $line\n
|
|
}
|
|
}
|
|
close $f
|
|
### reread y.output to get the state descriptions
|
|
set f [open $fname r]
|
|
while {![eof $f]} {
|
|
gets $f line
|
|
if {[regexp {state[ \t]*([0-9]+)$} $line match st]} {
|
|
set state($st) ""
|
|
gets $f line
|
|
if {[string trim $line] == ""} {
|
|
gets $f line
|
|
}
|
|
set rule ""
|
|
while {[regexp {[^\(]+\(rule ([0-9]+)\).*$} $line match rule1]} {
|
|
append state($st) [string trimleft $line]\n
|
|
gets $f line
|
|
set rule $rule1
|
|
}
|
|
#if {$rule != "" && [info exists action($rule)]} {
|
|
# append state($st) $action($rule)
|
|
#}
|
|
}
|
|
}
|
|
close $f
|
|
}
|
|
|
|
proc next {{update 1}} {
|
|
global gdb win state
|
|
sendgdb "c"
|
|
if {![regexp {.*source_lineno *= *([0-9]+).*} $gdb(answer) \
|
|
match gdb(lineno)]} {
|
|
.status.loaded config -bg blue
|
|
return
|
|
}
|
|
if {$update} {
|
|
#regexp {.*yyssp *= *([0-9]+).*} $gdb(answer) match gdb(state)
|
|
regexp {.*yystate *= *([0-9]+).*} $gdb(answer) match gdb(state)
|
|
regexp {.*yytext *= *[^\"]*\"([^\n]*)\n.*} $gdb(answer) match gdb(tok)
|
|
set gdb(tok) [string range $gdb(tok) 0 end-1]
|
|
$win(state) delete 0.0 end
|
|
#$win(state) insert end $state($gdb(state))
|
|
if {[info exists state($gdb(state))]} {
|
|
show_state $win(state) $state($gdb(state))
|
|
}
|
|
sendgdb "p ftell(o_src)"
|
|
regexp {.*= *([0-9]+)} $gdb(answer) match pos
|
|
if {![info exists pos]} {
|
|
#.status.loaded config -bg blue
|
|
return -1
|
|
}
|
|
if {$pos != $gdb(asmpos)} {
|
|
sendgdb "p fflush(o_src)"
|
|
set f [open $gdb(asmfile) r]
|
|
seek $f $gdb(asmpos) start
|
|
$win(asm) tag remove last 0.0 end
|
|
while {![eof $f]} {
|
|
gets $f line
|
|
$win(asm) insert end $line\n last
|
|
}
|
|
close $f
|
|
$win(asm) see end
|
|
set gdb(asmpos) $pos
|
|
}
|
|
}
|
|
$win(source) tag remove line 0.0 end
|
|
set n $gdb(lineno)
|
|
$win(source) tag add line $n.0 $n.end
|
|
$win(source) see [expr $n+3].0
|
|
$win(source) see $n.0
|
|
if {$update} {
|
|
show_lvals 0
|
|
}
|
|
return $gdb(state)
|
|
}
|
|
|
|
proc show_state {w st} {
|
|
global action arule win
|
|
set i [string first " . " $st]
|
|
if {$i > 0} {
|
|
$w insert end [string range $st 0 [expr $i]] normal \
|
|
" " highlight [string range $st [expr $i+2] end] normal
|
|
} else {
|
|
$w insert end $st
|
|
}
|
|
set rule ""
|
|
if {[regexp {[^\(]+\(rule ([0-9]+)\).*$} $st match rule]} {
|
|
if {$rule != ""} {
|
|
$win(grammar) see $arule($rule).0
|
|
}
|
|
}
|
|
# show mid-of-rule actions found
|
|
#while {[regexp {\$\$([0-9]+)[ \t]*:(.*)} $st match actn st]} {
|
|
# if {[info exists action($actn)]} {
|
|
# $w insert end "\$\$$actn: $action($actn)\n" action
|
|
# }
|
|
#}
|
|
}
|
|
|
|
proc run {} {
|
|
global gdb
|
|
if {$gdb(fd) < 0} {
|
|
ask_load_first
|
|
return
|
|
}
|
|
set until [.ctrl.until get]
|
|
if {$until != ""} {
|
|
while {$gdb(lineno) < $until} {
|
|
next 0
|
|
}
|
|
next
|
|
set gdb(until) ""
|
|
} else {
|
|
#set state $gdb(state)
|
|
#while {$state == $gdb(state)} {
|
|
# if {[next] < 0} break
|
|
#}
|
|
next
|
|
}
|
|
}
|
|
|
|
proc gdbsh {} {
|
|
global gdb
|
|
if {![winfo exists .gdb]} {
|
|
toplevel .gdb
|
|
pack [frame .gdb.t] -fill both -expand 1
|
|
pack [frame .gdb.b] -fill x
|
|
pack \
|
|
[button .gdb.b.close -text close -command {wm withdraw .gdb}] \
|
|
[label .gdb.b.lb -text \
|
|
"Press right mouse button to get cmd history or \
|
|
use the keys <up>,<down>"] \
|
|
-side left
|
|
set t [create_text .gdb.t 18]
|
|
set gdb(shprompt) "gdb> "
|
|
$t tag config answer -foreground navy
|
|
$t insert insert $gdb(shprompt)
|
|
$t mark set limit insert
|
|
$t mark gravity limit left
|
|
focus $t
|
|
bind gdb <Up> { gdbHistory %W 1 ; break }
|
|
bind gdb <Down> { gdbHistory %W 0 ; break }
|
|
bind gdb <Return> { gdbEval %W ; break }
|
|
bind gdb <Any-Key> {
|
|
if [%W compare insert < limit] {
|
|
%W mark set insert end
|
|
}
|
|
}
|
|
bind gdb <3> { popupHistory %W %X %Y ; break }
|
|
bindtags $t [list gdb Text $t all]
|
|
} else {
|
|
wm deiconify .gdb
|
|
}
|
|
}
|
|
|
|
proc popupHistory { t x y } {
|
|
global gdb history
|
|
if {![winfo exists .popup]} {
|
|
toplevel .popup
|
|
wm transient .popup .gdb
|
|
wm geometry .popup +$x+$y
|
|
pack [button .popup.cancel -text cancel -command {
|
|
wm withdraw .popup }] -side bottom
|
|
pack [set lb \
|
|
[listbox .popup.lb -yscrollcommand {.popup.sb set}]] \
|
|
[scrollbar .popup.sb -orient vertical -command {.popup.lb yview}] \
|
|
-side left -fill y
|
|
bindtags $lb [list Listbox all $lb]
|
|
bind $lb <1> [list executeHistory $t %W]
|
|
}
|
|
.popup.lb delete 0 end
|
|
foreach it $history {
|
|
.popup.lb insert 0 $it
|
|
}
|
|
wm deiconify .popup
|
|
wm geometry .popup +$x+$y
|
|
}
|
|
|
|
proc executeHistory {t lb} {
|
|
global history
|
|
$t delete limit end
|
|
$t insert insert [string trimright [$lb get [$lb curselection]]]
|
|
wm withdraw .popup
|
|
gdbEval $t
|
|
}
|
|
|
|
proc gdbHistory { t up } {
|
|
global gdb history
|
|
if {$up} {
|
|
$t delete limit end
|
|
$t insert insert [lindex $history end]
|
|
set history [concat \
|
|
[lrange $history end end] [lrange $history 0 end-1]]
|
|
} else {
|
|
$t delete limit end
|
|
$t insert insert [lindex $history 0]
|
|
set history [concat \
|
|
[lrange $history 1 end] [lrange $history 0 0]]
|
|
}
|
|
}
|
|
|
|
proc gdbEval { t } {
|
|
global gdb history
|
|
set command [string trimright [$t get limit end]]
|
|
if {$command != ""} {
|
|
lappend history $command
|
|
set history [lrange $history 0 100]
|
|
}
|
|
$t insert insert \n
|
|
sendgdb $command
|
|
if {[string length $gdb(answer)] > 0} {
|
|
$t insert insert $gdb(answer)\n answer
|
|
}
|
|
$t insert insert $gdb(shprompt)
|
|
$t see insert
|
|
$t mark set limit insert
|
|
}
|
|
|
|
proc show_lvals {{update 1}} {
|
|
global gdb history
|
|
if {$gdb(fd) < 0} {
|
|
ask_load_first
|
|
return
|
|
}
|
|
if {$update && ![winfo exists .lvals]} {
|
|
toplevel .lvals
|
|
grid \
|
|
[listbox .lvals.lb1 -yscrollcommand {.lvals.sb1 set}] \
|
|
[scrollbar .lvals.sb1 -orient vertical \
|
|
-command {.lvals.lb1 yview}] \
|
|
[listbox .lvals.lb -yscrollcommand {.lvals.sb set}] \
|
|
[scrollbar .lvals.sb -orient vertical -command {.lvals.lb yview}] \
|
|
[text .lvals.t -width 60 -height 12 -takefocus 0] \
|
|
-stick nsew
|
|
grid [button .lvals.close -text close -command {
|
|
wm withdraw .lvals }] -stick w
|
|
foreach cast $gdb(cast_list) {
|
|
.lvals.lb1 insert end $cast
|
|
}
|
|
foreach lb {.lvals.lb .lvals.lb1} {
|
|
bindtags $lb [list Listbox all $lb]
|
|
bind $lb <1> [list showLval $lb]
|
|
}
|
|
}
|
|
if {![winfo exists .lvals] || !$update && ![winfo ismapped .lvals]} {
|
|
return
|
|
}
|
|
#wm withdraw .lvals
|
|
.lvals.lb delete 0 end
|
|
sendgdb "p &yyvs"
|
|
regexp {.*(0x[0-9xa-fA-F]+).*} $gdb(answer) match start
|
|
sendgdb "p yyvsp"
|
|
regexp {,*(0x[0-9a-fA-F]+).*} $gdb(answer) match end
|
|
set values {}
|
|
for {set i [expr ($end-$start)/8]} {$i >= 0} {incr i -1} {
|
|
sendgdb "p yyvs\[$i]"
|
|
regexp { ival = ([0-9a-fA-Fx]+).*} $gdb(answer) match lval
|
|
lappend values 0x[format %x $lval]
|
|
}
|
|
eval .lvals.lb insert 0 $values
|
|
wm deiconify .lvals
|
|
}
|
|
|
|
proc showLval {lb} {
|
|
global gdb
|
|
$lb activate [$lb curselection]
|
|
if {[.lvals.lb get active] == {} ||
|
|
[.lvals.lb1 get active] == {}} { return }
|
|
set cast [.lvals.lb1 get active]
|
|
set var [.lvals.lb get active]
|
|
if {[string index $cast end] == "*"} {
|
|
sendgdb "p *($cast) $var"
|
|
} else {
|
|
sendgdb "p ($cast) $var"
|
|
}
|
|
set result [string range $gdb(answer) \
|
|
[expr [string first = $gdb(answer)]+1] end]
|
|
set result [string trimleft $result " \t\n\{"]
|
|
set result [string trimright $result " \t\n\}"]
|
|
.lvals.t delete 0.0 end
|
|
foreach item [split $result ,] {
|
|
foreach {lhs rhs} [split [string trim $item] =] {}
|
|
.lvals.t insert end $lhs\t$rhs\n
|
|
}
|
|
}
|
|
|
|
proc show_value {var} {
|
|
global gdb
|
|
if {[string first "-" $var]} {
|
|
sendgdb "p '$var'"
|
|
} else {
|
|
sendgdb "p $var"
|
|
}
|
|
tk_messageBox -type ok -message "Inspect $var\n$gdb(answer)"
|
|
}
|
|
|
|
proc create_text {w {height 10} {width 40}} {
|
|
text $w.t -width $width -height $height -wrap word \
|
|
-yscrollcommand "$w.sv set" -xscrollcommand "$w.sh set"
|
|
scrollbar $w.sv -orient vertical -command "$w.t yview"
|
|
scrollbar $w.sh -orient horizontal -command "$w.t xview"
|
|
pack $w.sh -side bottom -fill x
|
|
pack $w.sv -side right -fill y
|
|
pack $w.t -side left -fill both -expand 1
|
|
bindtags $w.t [list Text $w.t . all]
|
|
bind $w.t <Double-1> {show_value [%W get sel.first sel.last]}
|
|
bind $w.t <Control-1> {show_value [%W get sel.first sel.last]}
|
|
return $w.t
|
|
}
|
|
|
|
set w [frame .ctrl]
|
|
# [label $w.lab1 -text Source:] \
|
|
# [entry $w.sourcef -width 20 -textvariable gdb(sourcefile)] \
|
|
#
|
|
pack \
|
|
[button $w.load -command load -text load] \
|
|
[button $w.run -command run -text "run until"] \
|
|
[entry $w.until -width 4 -textvariable gdb(until)] \
|
|
[button $w.gdbsh -command gdbsh -text gdbsh] \
|
|
[button $w.lval -command show_lvals -text "lval stack"] \
|
|
[button $w.exit -command exit -text exit] \
|
|
-side left -pady 10 -padx 5
|
|
set w [frame .status]
|
|
pack \
|
|
[label $w.lab2 -text Line:] \
|
|
[label $w.lab3 -relief sunken -bd 2 -width 4 -textvariable gdb(lineno)] \
|
|
[label $w.lab4 -text State:] \
|
|
[label $w.lab5 -relief sunken -bd 2 -width 4 -textvariable gdb(state)] \
|
|
[label $w.lab6 -text Token:] \
|
|
[label $w.lab7 -relief sunken -bd 2 -width 20 -textvariable gdb(tok)] \
|
|
[frame $w.loaded -relief sunken -bd 2 -width 10 -height 10] \
|
|
-side left -pady 10 -padx 5
|
|
|
|
panedwindow .pw1 -orient horizontal
|
|
panedwindow .pw2 -orient vertical
|
|
panedwindow .pw3 -orient vertical
|
|
.pw1 add .pw2
|
|
.pw1 add .pw3
|
|
set win(source) [create_text [frame .f1]]
|
|
set win(state) [create_text [frame .f2] 8]
|
|
set win(asm) [create_text [frame .f3] 10]
|
|
set win(grammar) [create_text [frame .f4] 6]
|
|
.pw2 add .f2
|
|
.pw2 add .f4
|
|
.pw3 add .f1
|
|
.pw3 add .f3
|
|
pack .ctrl .status -fill both
|
|
pack .pw1 -fill both -expand 1
|
|
|
|
$win(state) tag config highlight -background red
|
|
$win(state) tag config action -foreground darkgreen
|
|
$win(state) tag config normal -foreground black
|
|
$win(asm) tag config last -foreground maroon
|
|
$win(source) tag config line -background navy -foreground yellow
|
|
|
|
update idletasks
|
|
parse_yacc_states [file join $gdb(compiler_path) htcobol.output] \
|
|
[file join $gdb(compiler_path) htcobol.y]
|
|
|
|
bind all <Control-r> run
|
|
bind all <Control-c> exit
|
|
wm title . "NO COBOL SOURCE LOADED"
|
|
|