The code below is self explaining.

======
#
# tcltags.tcl
#
# plp / _abc_ @ irc.freenode.net
#
# Parses a tcl program partially to extract the call 
# tree and/or generates a ctags tags file compatible with vi/vim.
#
# Currently parses only one program per call. The output of
# several calls can be concatenated into a single tags file
# using cat or >> redirection etc.
#
# The program ONLY writes to stdout. The default output is a
# textual representation of the call chart for human use.
#
# Options:
# --sort-uniq   sorts and uniqs called procs in each proc.
# --tags        generates a vim compatible tags file on stdout.
# --            standard option to indicate end of options.
#
# Example:
#
# tcltags.tcl --tags somesource.tcl >tags
#
# Assumptions:
# - Procs are defined with the word proc starting in column 0 and are followed
# by a { on the same line (no \\n continuation). Proc names must match the 
# regexp /[_A-Za-z][_0-9A-Za-z]*/ .
# - Each proc ends with a '}' in column 0.
# - No nested procs (private procs) are recognized.
# - No library include or sourced files are considered.
#
# Versions:
# 0.1a fixes regexps used in vim tags files
#
#\
        exec /usr/bin/env tclsh "$0" "$@"

# script version
set Version "0.1a"

# parameter: 1 sorts and uniqs called procs in lists of called procs,
# affects only Stdout output, cli --sort-uniq
set SortUniq 0

# parameter: 1 writes a ctags compatible output file, cli --tags
set Ctags 0

# parameter: 1 writes a representation of the data on stdout,
# this is the default, and is turned off by --tags
set Stdout 1

# start
set Data "" ;# collect file data here

# currently the program must be called with one argument
# every time. The output tags files can be merged by
# cat-ing them simply together, or >>to the output on each
# call.
if {[lindex $argv 0] eq "--tags"} {
        set Ctags 1
        set Stdout 0
        set argv [lrange $argv 1 end]
} else {
        if {[lindex $argv 0] eq "--sort-uniq"} {
                set SortUniq 1
                set argv [lrange $argv 1 end]
        }
}

# check there are no more options, standard -- is accepted
if {[regexp {^--.+} [lindex $argv 0]]} {
        puts stderr "error: invalid option '[lindex $argv 0]'"
        exit 2
}
if {[regexp {^--$} [lindex $argv 0]]} {
        set argv [lrange $argv 1 end]
}

if {[llength $argv] != 1} {
        puts stderr "usage: [file tail $argv0] filename.tcl"
        exit 2
}

foreach arg $argv {
        if { [catch { 
                set fd [open $arg "r"] 
                append Data [read $fd] 
                close $fd 
        } err] } {
                puts stderr "Error: open [lindex $argv 1]: $err"
                exit 1
        }
}

# determine the names of the functions
catch {array unset Functions}
array set Functions ""
set procname0 ""
set lineno 0
set Data1 [split $Data "\n"]
foreach lin $Data1 {
        incr lineno
        if {[regexp {^proc[ \t]+([_A-Za-z][_0-9A-Za-z]*)[ \t]+\{} $lin \
                dummy procname] \
        } {
                set Functions($procname) $lineno
                set procname0 $procname
                continue
        }
        if {[regexp {^\}} $lin] } {
                if {$procname0 ne ""} {
                        lappend Functions($procname0) $lineno
                        set procname0 ""
                }
        }
}

# debug
#puts [join [lsort [array names Functions] ] "\n"]

# for each found function look inside it for the others
foreach procname [array names Functions] {
        set t $Functions($procname)
        set flist ""
        foreach lin [lrange $Data1 [lindex $t 0] [lindex $t 1] ] {
                foreach pname [array names Functions] {
                        if {$pname eq $procname} {continue}
                        #if {$pname in [list $lin]} {lappend flist $pname}
                        if {[regexp "\[\[:<:\]\]$pname\[\[:>:\]\]" $lin]} {lappend flist $pname}
                }
        }
        if {$flist ne ""} {
                if $SortUniq {set flist [lsort -uniq $flist]}
                lappend Functions($procname) {*}$flist
        } else {
        }
}

# sorted line list for in-procedure lines, format {x0 x1} ...
# uses the fact that procs do not nest (local procs don't work with
# this code!)
set sll ""
foreach pname [array names Functions] {
        lappend sll [lrange $Functions($pname) 0 1]
}
set sll [lsort -integer -index 0 $sll]

set sll1 ""
foreach x $sll {
        lappend sll1 {*}$x
}
set sll $sll1
unset sll1

# find toplevel function calls
set lineno 0
set slli 0 ;# index into sll
set Topf ""
foreach lin $Data1 {
        incr lineno
        if {$lineno == [lindex $sll $slli]} {
                incr slli
        }
        if {($slli % 2) == 0} { ;# slli is even outside functions
                foreach fn [array names Functions] {
                        if {[regexp "\[\[:<:\]\]$fn\[\[:>:\]\]" $lin]} {
                                lappend Topf [list $fn $lineno]
                        }
                }
        }
}

if $Stdout {
        # generate output
        puts "* tcltags version $Version plp 2011"
        puts "***INPUT"
        puts [join $argv "\n"]
        puts "*** FUNCTIONS"
        puts "* Format: Function Startline:Endline Length (in lines)"
        foreach fn [lsort [array names Functions] ] {
                set t $Functions($fn)
                puts "proc $fn [join [lrange $t 0 1] ":"] [expr {[lindex $t 1]-[lindex $t 0]}] L"
                foreach fn1 [lrange $t 2 end] {
                        puts "    $fn1"
                }
        }
        puts "*** TOP LEVEL CALLS"
        foreach t $Topf {
                foreach {fn lineno} $t {
                        puts "$fn $lineno"
                }
        }
        puts "*** END"
}

if $Ctags {
        set t0 [lindex $argv 0]
        foreach fn [lsort [array names Functions] ] {
                puts "$fn\t$t0\t/^proc\\s\\+$fn\\s\\+\{/"
        }
}

# vim:ts=2:sw=2
======

<<categories>>dev. tools | parsing