OXYGENHUB
◆ main openmsx / share / scripts / sdcdb.tcl
29.1 KiB · Tcl · last changed chore(): initial commit 1 month ago source blame history raw
e8555c89 Andy McCall 1 
# SDCDB Debugger in Tcl - Version 0.8
2 
#
3 
# Copyright 2025 Pedro de Medeiros all rights reserved
4 
#
5 
# A debugger written in Tcl that uses `SDCC --debug` parameter to create breakpoints and much more.
6 
#
7 
# The main difference between SDCC Debugger's breakpoints and the built-in openMSX breakpoints is the
8 
# C code integration:
9 
# [*] allow users to create breakpoints on C code:
10 
#     > sdcdb break main.c:55
11 
# [*] list C source code at line 100:
12 
#     > sdcdb list main.c:100
13 
# [*] step through the source code
14 
#     > sdcdb step
15 
# [*] and more things to come (WIP).
16 
#
17 
# All commands that the SDCDB Debugger recognizes directly. You may call them with sdcdb [COMMAND] [ARGS...]:
18 
#
19 
# open ?-recursive? <directories> [<pathToCDBFile>]
20 
#       - Start debugging session, reading source files and a CDB file specified by parameters.
21 
#         -recursive enables recursive searching in subdirectories.
22 
# break <file>:<line>
23 
#       - creates breakpoint in <file>:<line>
24 
# list ?<line>?
25 
#       - list source code at <file>:<line>[-<line>]
26 
# info ?-break?
27 
#       - Display information on source code under the program counter. The -break parameter
28 
#         parameter stops execution.
29 
# step ?<n>?
30 
#       - Executes next n lines of C code step by step, proceeding through subroutine calls.
31 
#         n defaults to 1.
32 
# next ?<n>?
33 
#       - The 'sdcdb next' is like 'sdcdb step' but will not proceed through subroutine calls.
34 
#         You may specify how many n times 'sdcdb next' should execute (defaults to 1).
35 
# whereis <fileName>
36 
#       - Checks if a C/assembly source file was included in a scan from `sdcdb open` and
37 
#         returns the path to the file.
38 
# map <file>:<line>
39 
#       - Returns memory address of <file>:<line>, accepting same parameters of 'sdcdb break',
40 
#         but without creating breakpoints.
41 
# laddr <address>
42 
#       - Returns the C/assembly source code associated with a memory address.
43 
#
44 
# Known limitations:
45 
# [*] don't create C files with same name in different folders (in projects with multiple
46 
#     folders), since CDB files don't keep track of directories, just file names. SDCDB
47 
#     will get lost and report the wrong position because of missing files during break or
48 
#     step.
49 
# [*] don't create projects with assembly and C files with the same name, since SDCC
50 
#     already creates an .asm file for every .c file in your project. SDCDB will get lost
51 
#     and report the wrong position because of missing files during break or step.
52 
#
53 
# For more information about the CDB file format: https://sourceforge.net/p/sdcc/wiki/Home/
54
55 
namespace eval sdcdb {
56
57 
variable initialized    0
58 
variable c_files_count                  ;# C files reference
59 
variable a_files_count                  ;# ASM files reference
60 
array set c_files       {}              ;# pool of c source files
61 
array set a_files       {}              ;# pool of a source files
62 
array set addr2file     {}              ;# array that maps to source from address
63 
array set g_func2addr   {}              ;# array that maps to address from source (global)
64 
# array set c_<filename>2addr           ;# same, but dinamically created array for each SDCC module (C file)
65 
# array set a_<filename>2addr           ;# same, but dinamically created array for each SDCC module (ASM file)
66 
# array set <filename>_func2addr        ;# array that maps function to source (static)
67 
variable current_file   {}              ;# debugger file
68 
variable current_line   {}              ;# debugger line
69 
variable cond           {}              ;# breakpoint check condition
70 
variable old_PC         {}
71 
variable times_left     0
72 
variable out_of_scope   0               ;# running without debug info?
73 
proc ASM {} { return ".asm" }
74
75 
set_help_proc sdcdb [namespace code sdcdb_help]
76 
proc sdcdb_help {args} {
77 
    if {[llength $args] == 1} {
78 
        return {The SDCDB debugger in Tcl connects openMSX to the CDB file created by SDCC.
79
80 
Recognized commands: open, break, list, step, next, info, whereis, laddr, map
81
82 
Type 'help sdcdb <command>' for more information about each command.
83 
}
84 
    }
85 
    switch -- [lindex $args 1] {
86 
        "open" { return {Opens a project directory and start debugging session
87
88 
'sdcdb open' will scan directories for source files and also search for a single CDB file in them, or you may specify the path to a CDB file directly (a single file probably named <projectName>.cdb) in addition to the source files.
89
90 
Syntax: sdcdb open <directories> [<.cdbFile>]
91 
}}
92 
        "break" { return {Creates a breakpoint
93
94 
Create an openMSX breakpoint, but using the C source files as reference. 'sdcdb info -break' replaces 'debug break' for extra details about C code execution.
95
96 
Syntax: sdcdb break <file>:<line>
97 
        sdcdb break <file>:<functionName>
98 
        sdcdb break <functionName>
99 
}}
100 
        "list" { return {Lists contents of a C source file
101
102 
Without parameters, 'sdcdb list' returns the C/assembly source code under the PC register. Obs.: assembly function names are not recognized.
103
104 
Syntax: sdcdb list
105 
        sdcdb list <file>:<line>
106 
        sdcdb list <file>:<functionName>
107 
        sdcdb list <functionName>
108 
}}
109 
        "laddr" { return {Lists contents of C/assembly source code in a specified memory address
110
111 
Syntax: sdcdb laddr mem
112 
}}
113 
        "step" { return {Steps through next n lines of C code
114
115 
The 'sdcdb step' command will proceed through subroutine calls. You may specify how many times 'sdcdb step' should execute (defaults to 1).
116
117 
Syntax: sdcdb step ?n?
118 
}}
119 
        "next" { return {Executes next n lines of C code
120
121 
The 'sdcdb next' command will not proceed through subroutine calls. You may specify how many times 'sdcdb next' should execute (defaults to 1).
122
123 
Syntax: sdcdb next ?n?
124 
}}
125 
        "info" { return {Displays information about current line of source code
126
127 
A '-break' parameter stops execution after displaying the information.
128
129 
Syntax: sdcdb info ?-break?
130 
}}
131 
        "whereis" { return {Displays if source file was found in the database
132
133 
Syntax: sdcdb whereis <sourceFileName>
134 
}}
135 
        "map" { return {Returns memory address from a C/assembly file line
136
137 
Basically a dry-run version of 'sdcdb break'. If a functionName is used, it returns the beginning and ending address of the function.
138
139 
Syntax: sdcdb map <file>:<line>
140 
        sdcdb map <file>:<functionName>
141 
        sdcdb map <functionName>
142 
}}
143 
    }
144 
}
145
146 
proc debug_out {args} {
147 
    variable debug
148 
    if {$debug} {
149 
        set chan stderr
150 
        set msg [string map {"\n" "\\n"} [join $args " "]]
151 
        puts $chan $msg
152 
        flush $chan
153 
    }
154 
}
155
156 
proc sdcdb {args} {
157 
    if {[catch {set result [dispatcher {*}$args]} msg]} {
158 
        debug_out stderr $::errorInfo
159 
        error $msg
160 
    }
161 
    return $result
162 
}
163
164 
proc dispatcher {args} {
165 
    set params "[lrange $args 1 end]"
166 
    set cmd [lindex $args 0]
167 
    switch -- $cmd {
168 
        open    { return [sdcdb_open       {*}$params] }
169 
    }
170 
    # remaining commands need initialization
171 
    variable initialized
172 
    if {!$initialized} {
173 
        error "You need a CDB file to use this command. Use the 'sdcdb open' command first"
174 
    }
175 
    switch -- $cmd {
176 
        break   { return [sdcdb_break      {*}$params] }
177 
        list    { return [sdcdb_list       {*}$params] }
178 
        info    { return [sdcdb_info       {*}$params] }
179 
        step    { return [sdcdb_step       {*}$params] }
180 
        next    { return [sdcdb_next       {*}$params] }
181 
        whereis { return [sdcdb_whereis    {*}$params] }
182 
        laddr   { return [sdcdb_laddr      {*}$params] }
183 
        map     { return [sdcdb_map        {*}$params] }
184 
        default { error "Unknown command \"[lindex $args 0]\"." }
185 
    }
186 
}
187
188 
proc sdcdb_open {param args} {
189 
    free
190 
    set function normal_glob
191 
    if {$param eq "-recursive"} {
192 
        set function recursive_glob
193 
    } else {
194 
        set args [linsert $args 0 $param]
195 
    }
196 
    set cdb_file {}
197 
    foreach path $args {
198 
        if {![file exists $path]} {
199 
            error "file '$path' not found"
200 
        }
201 
        if {[file isdirectory $path]} {
202 
            set new_files [$function $path *.c]
203 
            debug_out "adding files: [join $new_files {, }]"
204 
            add_files_to_database c_files $new_files
205 
            set new_files [$function $path *[ASM]]
206 
            debug_out "adding files: [join $new_files {, }]"
207 
            add_files_to_database a_files $new_files
208 
            set cdb_files [$function $path *.cdb]
209 
        } elseif {[file isfile $path] && [file extension $path] eq ".cdb"} {
210 
            set cdb_file $path
211 
        }
212 
    }
213 
    if {$cdb_file eq {}} {
214 
        if {[llength $cdb_files] > 1} {
215 
            error "multiple CDB files found, you may specify one as a parameter to 'scdb open'"
216 
        } elseif {[llength $cdb_files] == 0} {
217 
            error "CDB file not found"
218 
        }
219 
        set cdb_file $cdb_files
220 
    }
221 
    variable initialized
222 
    set initialized 1
223 
    set result [read_cdb $cdb_file]
224 
    process_data
225 
    return $result
226 
}
227
228 
proc complete {arrayname name list} {
229 
    variable $arrayname
230 
    if {![info exists ${arrayname}($name)]} {
231 
        debug_out "$arrayname\($name\) ignored"; return 0
232 
    }
233 
    set ${arrayname}($name) [concat {*}[set ${arrayname}($name)] {*}$list]
234 
    return 1
235 
}
236
237 
proc read_cdb {fname} {
238 
    variable c_files_count
239 
    variable addr2file
240 
    set fh [open $fname "r"]
241 
    # function pattern: search for "F:G$function_name$..." lines
242 
    set func_pat {^F:(G|F([^$]+)|L([^$]+))\$([^$]+)\$.*}
243 
    # ASM line number pattern: search for "L:A$filename$line:address" lines
244 
    set aline_pat {^L:A\$([^$]+)\$([^$]+):([^$]+)$}
245 
    # C line number pattern: search for "L:C$filename$line$level$block:address" lines
246 
    set cline_pat {^L:C\$([^$]+)\$([^$]+)\$([^$]+)\$([^$]+):(\S+)$}
247 
    # function begin pattern: search for "L:(G|F<name>|L<name>)$function$level$block:address" lines
248 
    set func_bn_pat {^L:(G|F([^$]+)|L([^$]+))\$([^$]+)\$([^$]+)\$([^$]+):(\S+)$}
249 
    # function end pattern: search for "L:X(G|F<name>|L<name>)$function$level$block:address" lines
250 
    set func_ed_pat {^L:X(G|F([^$]+)|L([^$]+))\$([^$]+)\$([^$]+)\$([^$]+):(\S+)$}
251 
    set c_count 0  ;# lines of C code
252 
    set a_count 0  ;# lines of asm code
253 
    set gf_count 0 ;# global functions
254 
    set sf_count 0 ;# static functions
255 
    while {[gets $fh line] != -1} {
256 
        set match [regexp -inline $func_pat $line]
257 
        if {[llength $match] == 5} {
258 
            lassign $match {} context {} {} funcname
259 
            switch -- [string index $context 0] {
260 
                G {
261 
                    variable g_func2addr
262 
                    set g_func2addr($funcname) {}
263 
                    debug_out "g_func2addr\($funcname\) created"
264 
                }
265 
                F {
266 
                    set arrayname [string range $context 1 [string length $context]]_func2addr
267 
                    variable $arrayname
268 
                    set ${arrayname}($funcname) {}
269 
                    debug_out "${arrayname}\($funcname\) created"
270 
                }
271 
                L {}
272 
            }
273 
            continue
274 
        }
275 
        set match [regexp -inline $cline_pat $line]
276 
        if {[llength $match] == 6} {
277 
            lassign $match {} filename linenum {} {} address
278 
            set address [expr {"0x$address"}]
279 
            # Put line -> address mapping of array with dynamic name
280 
            set arrayname c_[file rootname $filename]2addr
281 
            incr c_files_count($filename)
282 
            if {$c_files_count($filename) eq 1} {
283 
                debug_out "Created new dynamic array $arrayname"
284 
            }
285 
            variable $arrayname
286 
            # <file>2addr: linenum to address
287 
            set ${arrayname}($linenum) $address
288 
            # address to file:linenum
289 
            set record [lindex [array get addr2file $address] 1]
290 
            if {$record ne {}} {
291 
                lassign $record old_file {}
292 
                # Stop C code from overwriting used address.
293 
                if {$filename eq $old_file} {
294 
                    debug_out "not mapping [h $address] to C source: address already taken by '$old_file'"
295 
                    continue
296 
                }
297 
            }
298 
            set addr2file($address) [list $filename $linenum]
299 
            debug_out "mapping C source ${arrayname}\($linenum\): [set ${arrayname}($linenum)] ($line)"
300 
            incr c_count
301 
            continue
302 
        }
303 
        set match [regexp -inline $aline_pat $line]
304 
        if {[llength $match] == 4} {
305 
            lassign $match {} filename linenum address
306 
            set address [expr {"0x$address"}]
307 
            # Put line -> address mapping of array with dynamic name
308 
            set arrayname a_${filename}2addr
309 
            set filename $filename[ASM]
310 
            incr a_files_count($filename)  ;# SDCC removes the file extension for some reason
311 
            if {$a_files_count($filename) eq 1} {
312 
                debug_out "Created new dynamic array $arrayname"
313 
            }
314 
            variable $arrayname
315 
            # <file>2addr: linenum to address
316 
            set ${arrayname}($linenum) $address
317 
            set addr2file($address) [list $filename $linenum]
318 
            debug_out "mapping asm source ${arrayname}\($linenum\): [set ${arrayname}($linenum)]"
319 
            incr a_count
320 
            continue
321 
        }
322 
        set match [regexp -inline $func_bn_pat $line]
323 
        if {[llength $match] == 8} {
324 
            lassign $match {} context {} {} funcname {} {} address
325 
            set address [expr {"0x$address"}]
326 
            # Put function begin record in array with dynamic name
327 
            switch -- [string index $context 0] {
328 
                G {
329 
                    variable g_func2addr
330 
                    # g_func2addr: funcname -> start address (global)
331 
                    if {[complete g_func2addr $funcname [list $address]]} {
332 
                        debug_out "mapping function g_func2addr\($funcname\): [set g_func2addr($funcname)]"
333 
                        incr gf_count
334 
                    }
335 
                }
336 
                F {
337 
                    # <file>_func2addr: funcname -> start address (static)
338 
                    set arrayname [string range $context 1 [string length $context]]_func2addr
339 
                    variable $arrayname
340 
                    if {[complete $arrayname $funcname [list $address]]} {
341 
                        debug_out "mapping function ${arrayname}\($funcname\): [set ${arrayname}($funcname)]"
342 
                        incr sf_count
343 
                    }
344 
                }
345 
                L {}
346 
            }
347 
            continue
348 
        }
349 
        set match [regexp -inline $func_ed_pat $line]
350 
        if {[llength $match] == 8} {
351 
            lassign $match {} context {} {} funcname {} {} address
352 
            set address [expr {"0x$address"}]
353 
            # Put function end record in array with dynamic name
354 
            switch -- [string index $context 0] {
355 
                G {
356 
                    # g_func2addr: funcname -> end address (global)
357 
                    variable g_func2addr
358 
                    if {[complete g_func2addr $funcname [list $address]]} {
359 
                        debug_out "mapping function g_func2addr\($funcname\): [set g_func2addr($funcname)]"
360 
                    }
361 
                }
362 
                F {
363 
                    # <file>_func2addr: funcname -> end address (static)
364 
                    set arrayname [string range $context 1 [string length $context]]_func2addr
365 
                    variable $arrayname
366 
                    if {[complete $arrayname $funcname [list $address]]} {
367 
                        debug_out "mapping function ${arrayname}\($funcname\): [set ${arrayname}($funcname)]"
368 
                    }
369 
                }
370 
                L {
371 
                }
372 
            }
373 
            continue
374 
        }
375 
        debug_out "Ignored '$line'"
376 
    }
377 
    close $fh
378 
    variable c_files
379 
    variable a_files
380 
    set result ""
381 
    append result "[array size c_files] C files added\n"
382 
    append result "[array size a_files] assembly files added\n"
383 
    append result "[array size c_files_count] C files references added\n"
384 
    append result "[array size a_files_count] assembly files references added\n"
385 
    append result "$c_count C source lines found\n"
386 
    append result "$a_count assembly source lines found\n"
387 
    append result "$gf_count global function(s) registered\n"
388 
    append result "$sf_count static function(s) registered\n"
389 
    return $result
390 
}
391
392 
proc fix_blank_spaces {arrayname} {
393 
    variable $arrayname
394 
    set old_key {}
395 
    foreach key [lsort -integer [array names $arrayname]] {
396 
        if {$old_key ne {} && [expr {$key - 1}] != $old_key} {
397 
            for {set i [expr {$old_key + 1}]} {$i < $key} {incr i} {
398 
                #debug "Setting $arrayname\($i\) to ${arrayname}\($old_key\) = [set ${arrayname}($old_key)]"
399 
                set ${arrayname}($i) [set ${arrayname}($old_key)]
400 
            }
401 
        }
402 
        set old_key $key
403 
    }
404 
}
405
406 
proc fix_last_address {arrayname} {
407 
    variable $arrayname
408 
    set old_key {}
409 
    set sorted [lsort -integer [array names $arrayname]]
410 
    foreach key $sorted {
411 
        if {$old_key ne {} && [set ${arrayname}($old_key)] ne [set ${arrayname}($key)]} {
412 
            set ${arrayname}($old_key) [list [set ${arrayname}($old_key)] [expr {[set ${arrayname}($key)] - 1}]]
413 
        } elseif {$old_key ne {}} {
414 
            set ${arrayname}($old_key) [list [set ${arrayname}($old_key)] [set ${arrayname}($old_key)]]
415 
        }
416 
        set old_key $key
417 
    }
418 
    if {[llength $sorted] > 0} {
419 
        # change last value
420 
        set last [lindex $sorted end]
421 
        set ${arrayname}($last) [list [set ${arrayname}($last)] [set ${arrayname}($last)]]
422 
    }
423 
}
424
425 
proc process_data {} {
426 
    variable c_files
427 
    foreach filename [array names c_files] {
428 
        set arrayname c_[file rootname $filename]2addr
429 
        variable $arrayname
430 
        fix_last_address $arrayname
431 
        fix_blank_spaces $arrayname
432 
    }
433 
    variable a_files
434 
    foreach filename [array names a_files] {
435 
        set arrayname a_[file rootname $filename]2addr
436 
        variable $arrayname
437 
        fix_last_address $arrayname
438 
        fix_blank_spaces $arrayname
439 
    }
440 
    fix_blank_spaces addr2file
441 
}
442
443 
proc normal_glob {dir pattern} {
444 
    glob -nocomplain -type f -directory $dir $pattern
445 
}
446
447 
proc recursive_glob {dir pattern} {
448 
    set result [list]
449 
    foreach file [glob -nocomplain -directory $dir $pattern] {
450 
        lappend result $file
451 
    }
452 
    foreach subdir [glob -nocomplain -directory $dir *] {
453 
        if {[file isdirectory $subdir]} {
454 
            lappend result {*}[recursive_glob $subdir $pattern]
455 
        }
456 
    }
457 
    return $result
458 
}
459
460 
proc add_files_to_database {arrayname files} {
461 
    variable $arrayname
462 
    foreach path $files {
463 
        set filename [file tail $path]
464 
        if {[array get $arrayname $filename] ne {}} {
465 
            debug_out "file '$filename' already registered in $arrayname, new entry ignored."
466 
        }
467 
        set ${arrayname}($filename) $path
468 
    }
469 
}
470
471 
proc sdcdb_list {args} {
472 
    # parameter pattern 1: file:beginLine-endLine
473 
    set pattern1 {([^:]+):(\d+)(-(\d+))?}
474 
    # parameter pattern 2: file:functionName
475 
    set pattern2 {([^:]+):(\S+)}
476 
    # parameter pattern 3: functionName
477 
    set pattern3 {(\S+)}
478 
    set arg [lindex $args 0]
479 
    set match [regexp -inline $pattern1 $arg]
480 
    if {[llength $match] == 5} {
481 
        lassign $match {} file start {} end
482 
        return [list_file $file $start $end 0 1]
483 
    }
484 
    set match [regexp -inline $pattern2 $arg]
485 
    if {[llength $match] == 3} {
486 
        lassign $match {} file funcname
487 
        return [list_func $file $funcname]
488 
    }
489 
    set match [regexp -inline $pattern3 $arg]
490 
    if {[llength $match] == 2} {
491 
        lassign $match {} funcname
492 
        return [list_func {} $funcname]
493 
    }
494 
    list_pc
495 
}
496
497 
proc list_file {file begin {end {}} {focus 0} {showerror 0}} {
498 
    if {[file extension $file] eq ".c"} {
499 
        set files c_files
500 
    } elseif {[file extension $file] eq [ASM]} {
501 
        set files a_files
502 
    } else {
503 
        error "Unknown or unspecified file extension"
504 
    }
505 
    variable $files
506 
    set record [array get $files $file]
507 
    if {$record eq {}} {
508 
        if {$showerror} {
509 
            error "file '$file' not found in database, add a directory that contains such file with 'sdcdb add <dir>'"
510 
        }
511 
        return "$file: not found"
512 
    }
513 
    debug_out "opening file [lindex $record 1]..."
514 
    set fh [open [lindex $record 1] r]
515 
    set pos 0
516 
    # 10 lines by default
517 
    if {$end eq {}} { set end [expr {$begin + 9}] }
518 
    set result ""
519 
    while {[gets $fh line] >= 0} {
520 
        incr pos
521 
        if {$pos >= $begin} {
522 
            append result "[format %-5d $pos][expr {$pos == $focus ? "*" : ":"}]    $line\n"
523 
        }
524 
        if {$pos >= $end} { break }
525 
    }
526 
    close $fh
527 
    return $result
528 
}
529
530 
proc list_pc {{x0 -1} {x1 9}} {
531 
    list_address [reg PC] $x0 $x1 1
532 
}
533
534 
proc list_addr2file {arrayname address} {
535 
    variable $arrayname
536 
    set address [expr {$address}]
537 
    return [lindex [array get $arrayname $address] 1]
538 
}
539
540 
proc list_address {address {x0 -1} {x1 9} {showerror 0}} {
541 
    set address [expr {$address}]
542 
    variable addr2file
543 
    set record [list_addr2file addr2file $address]
544 
    if {$record eq {}} {
545 
        set msg "database address not found for 0x[h $address]"
546 
        if {$showerror} { error $msg }
547 
        return $msg
548 
    }
549 
    lassign $record file begin
550 
    list_file $file [expr {$begin + $x0}] [expr {$begin + $x1}] $begin
551 
}
552
553 
proc sdcdb_laddr {address} {
554 
    list_address $address
555 
}
556
557 
proc list_func {filename funcname} {
558 
    set results {}
559 
    variable addr2file
560 
    foreach region [search_func $filename $funcname] {
561 
        lassign [lindex $region 0] begin end
562 
        set record [lindex [array get addr2file $begin] 1]
563 
        lassign $record filename lbegin
564 
        lassign [lindex [array get addr2file $end] 1] {} lend
565 
        append results "$filename:$funcname\n"
566 
        append results [list_file $filename $lbegin $lend 0 1]
567 
    }
568 
    if {$results eq {}} {
569 
        error "database function '$funcname' not found"
570 
    }
571 
    return $results
572 
}
573
574 
proc search_static_func {funcname {filename {}}} {
575 
    set results [list]
576 
    if {$filename ne {}} {
577 
        set arrayname [file rootname $filename]_func2addr
578 
        variable $arrayname
579 
        set result [lindex [array get $arrayname $funcname] 1]
580 
        if {$result ne {}} {
581 
            lappend results [lindex [array get $arrayname $funcname] 1]
582 
        }
583 
        return $results
584 
    }
585 
    variable c_files
586 
    foreach filename [array names c_files] {
587 
        set arrayname [file rootname $filename]_func2addr
588 
        variable $arrayname
589 
        set result [lindex [array get $arrayname $funcname] 1]
590 
        if {$result ne {}} {
591 
            lappend results $result
592 
        }
593 
    }
594 
    return $results
595 
}
596
597 
proc search_global_func {funcname {filename {}}} {
598 
    set results [list]
599 
    variable g_func2addr
600 
    set result [lindex [array get g_func2addr $funcname] 1]
601 
    if {$result eq {}} {
602 
        return $results
603 
    }
604 
    # No filename specified? Return first entry
605 
    if {$filename eq {} && $result ne {}} {
606 
        return [lappend results $result]
607 
    }
608 
    lassign $result begin end
609 
    variable addr2file
610 
    lassign [lindex [array get addr2file $begin] 1] tmp {}
611 
    if {$tmp ne {} && $tmp ne $filename} {
612 
        return $results
613 
    }
614 
    return [lappend results $result]
615 
}
616
617 
# scan static file database then global database for function by name
618 
proc search_func {filename funcname} {
619 
    set results [list]
620 
    set tmp1 [search_global_func $funcname $filename]
621 
    if {$tmp1 ne {}} { lappend results $tmp1 }
622 
    set tmp2 [search_static_func $funcname $filename]
623 
    if {$tmp2 ne {}} { lappend results $tmp2 }
624 
    if {$results eq {}} {
625 
        error "'$funcname' not found"
626 
    }
627 
    return $results
628 
}
629
630 
proc search_file {file line} {
631 
    set tmp [file rootname $file]
632 
    if {[file extension $file] eq ".c"} {
633 
        set arrayname c_${tmp}2addr
634 
        variable c_${tmp}2addr
635 
    } else {
636 
        set arrayname a_${tmp}2addr
637 
        variable a_${tmp}2addr
638 
    }
639 
    if {![info exists $arrayname]} {
640 
        error "'$file': source file not found ($arrayname)"
641 
    }
642 
    set result [array get $arrayname $line]
643 
    if {$result eq {}} {
644 
        error "line $line not found in file '$file'"
645 
    }
646 
    lindex $result 1
647 
}
648
649 
# recurring pattern
650 
proc map_source_params {pos fun1 fun2 fun3 args} {
651 
    # parameter pattern 1: file:beginLine
652 
    set pattern1 {([^:]+):(\d+)}
653 
    # parameter pattern 2: file:functionName
654 
    set pattern2 {([^:]+):(\S+)}
655 
    # parameter pattern 3: functionName
656 
    set pattern3 {(\S+)}
657 
    set match [regexp -inline $pattern1 $pos]
658 
    if {[llength $match] == 3} {
659 
        return [$fun1 {*}[lrange $match 1 end] {*}$args]
660 
    }
661 
    set match [regexp -inline $pattern2 $pos]
662 
    if {[llength $match] == 3} {
663 
        return [$fun2 {*}[lrange $match 1 end] {*}$args]
664 
    }
665 
    set match [regexp -inline $pattern3 $pos]
666 
    if {[llength $match] == 2} {
667 
        return [$fun3 {*}[lrange $match 1 end] {*}$args]
668 
    }
669 
    # ignore the rest
670 
}
671
672 
proc sdcdb_map {pos} {
673 
    map_source_params $pos map_fline map_ffunc map_func
674 
}
675
676 
proc map_fline {filename linenum} {
677 
    search_file $filename $linenum
678 
}
679
680 
proc map_ffunc {filename funcname} {
681 
    search_func $filename $funcname
682 
}
683
684 
proc map_func {funcname} {
685 
    search_func {} $funcname
686 
}
687
688 
proc sdcdb_break {pos {cond {}} {cmd {sdcdb info -break}}} {
689 
    map_source_params $pos break_fline break_ffunc break_func $cond $cmd
690 
}
691
692 
proc break_fline {filename linenum cond cmd} {
693 
    set record [search_file $filename $linenum]
694 
    if {$record eq {}} {
695 
        error "address not found"
696 
    } else {
697 
        debug breakpoint create -address [lindex $record 1] -condition $cond -command $cmd
698 
    }
699 
}
700
701 
proc break_ffunc {filename funcname cond cmd} {
702 
    set count 0
703 
    foreach region [search_func $filename $funcname] {
704 
        lassign [lindex $region 0] begin {}
705 
        debug breakpoint create -address $begin -condition $cond -command $cmd
706 
        incr count
707 
    }
708 
    if {$count eq 0} {
709 
        error "function not found"
710 
    }
711 
}
712
713 
proc break_func {funcname cond cmd} {
714 
    set count 0
715 
    foreach region [search_func {} $funcname] {
716 
        lassign [lindex $region 0] begin {}
717 
        debug breakpoint create -address $begin -condition $cond -command $cmd
718 
        incr count
719 
    }
720 
    if {$count eq 0} {
721 
        error "function not found"
722 
    }
723 
}
724
725 
proc check_status {file line} {
726 
    return "file: $file:$line, position: 0x[h [reg PC]]\n[list_pc -1 1]"
727 
}
728
729 
proc update_step {{type {step}}} {
730 
    variable out_of_scope
731 
    variable current_file
732 
    variable current_line
733 
    variable times_left
734 
    # different file position?
735 
    set record [find_source [reg PC]]
736 
    if {$record ne {} && $record ne [list $current_file $current_line]} {
737 
        lassign $record current_file current_line
738 
        incr times_left -1
739 
        set out_of_scope 0
740 
    }
741 
    # still looping under these conditions
742 
    if {$out_of_scope || $times_left > 0} {
743 
        after break "sdcdb::update_step $type"
744 
        $type  ;# call "step" or "step_over"
745 
    } else {
746 
        puts -nonewline [check_status $current_file $current_line]
747 
    }
748 
}
749
750 
proc find_source {address} {
751 
    variable addr2file
752 
    # get current source file
753 
    set record [lindex [array get addr2file [reg PC]] 1]
754 
    return $record
755 
}
756
757 
proc prepare_step {{n 1}} {
758 
    debug break  ;# just to be sure
759 
    variable times_left $n
760 
    # get current position in source code
761 
    set record [find_source [reg PC]]
762 
    lassign $record file line
763 
    lassign [search_file $file $line] begin end
764 
    debug_out "search_file: $file, $line -> [search_file $file $line]"
765 
    if {$begin ne {} && $end ne {}} {
766 
        variable current_file $file
767 
        variable current_line $line
768 
    } else {
769 
        variable out_of_scope 1
770 
        return "Possibly out of scope, skipping till we get back."
771 
    }
772 
}
773
774 
proc sdcdb_step {{n 1}} {
775 
    after break "sdcdb::update_step"
776 
    debug step
777 
    prepare_step $n
778 
}
779
780 
proc sdcdb_next {{n 1}} {
781 
    after break "sdcdb::update_step step_over"
782 
    prepare_step $n
783 
    step_over
784 
}
785
786 
proc check_info {} {
787 
    variable addr2file
788 
    if {[array get addr2file [reg PC]] eq {}} {
789 
        error "line mapping not found for 0x[h [reg PC]]"
790 
    }
791 
    lassign $addr2file([reg PC]) file line
792 
    if {$file eq {}} {
793 
        error "address [h [reg PC]] not found in database."
794 
    }
795 
    puts -nonewline [check_status $file $line]
796 
}
797
798 
proc sdcdb_info {{param {}}} {
799 
    if {$param eq "-break"} {
800 
        debug break
801 
    }
802 
    set result {}
803 
    if {[catch {set result [check_info]} msg]} {
804 
        debug_out stderr $::errorInfo
805 
        error $msg
806 
    }
807 
    puts -nonewline $result
808 
}
809
810 
proc sdcdb_whereis {file} {
811 
    foreach files {c_files a_files} {
812 
        variable $files
813 
        if {[info exists ${files}($file)]} {
814 
            return "'$file' found in database (as '[set ${files}($file)]')"
815 
        }
816 
    }
817 
    return "'$file' not found in database"
818 
}
819
820 
proc free {} {
821 
    variable initialized
822 
    if {!$initialized} {
823 
        return
824 
    }
825 
    variable c_files
826 
    foreach filename [array names c_files] {
827 
        set arrayname c_[file rootname $filename]2addr
828 
        variable $arrayname
829 
        catch {unset $arrayname}
830 
        set arrayname [file rootname $filename]_func2addr
831 
        variable $arrayname
832 
        catch {unset $arrayname}
833 
    }
834 
    variable a_files
835 
    foreach filename [array names a_files] {
836 
        set arrayname a_[file rootname $filename]2addr
837 
        variable $arrayname
838 
        catch {unset $arrayname}
839 
    }
840 
    catch {unset c_files}
841 
    variable c_files_count
842 
    catch {unset c_files_count}
843 
    variable addr2file
844 
    catch {unset addr2file}
845 
    variable g_func2addr
846 
    catch {unset g_func2addr}
847 
    set initialized 0
848 
}
849
850 
proc h {address} {
851 
    return [format %04X $address]
852 
}
853
854 
namespace export sdcdb
855
856 
}
857
858 
# Import sdcdb exported functions
859 
namespace import sdcdb::*
860
861 
set sdcdb::debug false