funcs.tcl

一个用TCL/TK写的用于verilog的集成编辑环境.

load "/root/nman/lib/tclsqlite.so"

# Procedures:
# lget               - get sublist of given list that matches regexp
# busplit            - splits given bus
# unique             - unique tcl list
# ldelete            - delete one list from another
# max, min           - no comments
# get                - returns the command result instead of printing it
# cb                 - change [ ] for ( ) and remove \

# create_db {design} - creates db file and tables for fiven design name
# parse_lib          - parses lib file to DB
# parse_file         - parses design file to DB
# read_verilog       - reads verilog file to DB
# read_lib (vfile)   - reads lib file to DB
# read_db (dbfile)   - link to existing DB file
 
# get_parent_cell    - get instance name from full pin name 
# current            - set current module
# check_current      - checks whether current design is defined
# get_lib_cells      - search for lib cells (modules)
# get_cells          - search for design cells (instances)
# get_modules        - get list of loaded modules
# get_nets           - get nets in current design
# get_ports          - get ports in current design
# get_pins           - get pins in current design
# get_lib_pins       - get pins of lib cells 
# get_mname          - get module name of given instance
# get_cnet           - get net connected to given pin
# get_cpins          - get pins connected to given net
# get_submodules     - get submodules of current module

# rm_cell            - removes cell from current design
# rm_net             - removes net  from current design
# rm_port            - removes port from current design
# rm_lib_mod         - removes library (leaf) module
# rm_mod             - removes module

# new_cell
# new_net
# new_mod
# new_lib_mod
# new_port

# link               - link design, checkin existence of all needed modules
# get_hier           - get hierarchy (textual)
# get_gui_hier       - get hierarchy (for GUI)



#===================================================================
proc lget {list regexp} {
  set ret_list "" 
  foreach val $list {
    if {[string match $regexp $val]} {
      lappend ret_list $val
    }
  }
  return [lsort $ret_list]
}

#==================================================================== 
proc put {args} {
  set TF [open tmpfile w]; puts $TF $args; close $TF
  set TF [open tmpfile r]
  gets $TF line
  close $TF
  $Tree::list insert end "$line\n"
}
#===================================================================
proc busplit {vals} {
  set ret_list ""
  foreach val $vals {
    if {[regexp {^(.+)\(([0-9]+):([0-9]+)\)$} $val m vname n1 n2]} {
      for {set i [min $n1 $n2]} {$i < [max $n1 $n2]} {incr i} {
        lappend ret_list "$vname\($i\)"
      }
    } else {
      lappend ret_list $val
    } 
  }
  return $ret_list
}

#======================================================
proc unique {bad_list} {
  set good_list {}
  foreach bad_item $bad_list {
    if {[lsearch -exact $good_list $bad_item] < 0} {
       lappend good_list $bad_item
    }
  }
  return $good_list
}

#======================================================
proc ldelete {list list_to_del} {
  foreach str $list_to_del {
    set ix [lsearch -exact $list $str]
    if {$ix >= 0} {set list [lreplace $list $ix $ix]}
  }
  return $list
}

#======================================================
proc max {n1 n2} {
  if {$n1 >= $n2} {
    return $n1
  } else {
    return $n2
  }
}

#==================================================================
proc min {n1 n2} {
  if {$n1 <= $n2} {
    return $n1
  } else {
    return $n2
  }
}
#===================================================================

proc cb {name} {
  regsub -all {\\} $name "" name1
  regsub -all {\[} $name1 \( name2
  regsub -all {\]} $name2 \) name3
  return $name3
}

#===================================================================
proc get_parent_cell {pin_name} {
  if {[regexp {^(.*)/[^/]+$} $pin_name m parent]} {
    return $parent
  } else {
    puts "Error in pin name; use following format: U809/A"
    return 0
  }
}

#===================================================================
proc check_current {} {
  global current
  if {$current == ""} {
    puts "Error: Current module is not defined. Existing modules:\n[get_modules *]"
    return 0
  }
}

#===================================================================
proc create_db {design} {
  if [file isfile $design.db] {
    exec rm $design.db
  }
  sqlite db $design.db
  db eval {CREATE TABLE lib(name text, inputs text, outputs text)}
  db eval {CREATE TABLE inst(name text, mname text, pname text, conn text)}
  db eval {CREATE TABLE net(name text, pname text)}
  db eval {CREATE TABLE port(name text, pname text)}
  db eval {CREATE TABLE mod(name text, pname text, inputs text, outputs text)}
}

#===================================================================
proc parse_lib {lfile} {
  if [catch {open $lfile r} VF] {
    puts stderr "Cannot open file $lfile!"
  }
  set acc_line ""; set comments false;
  set iports ""; set oports "";

  while {[gets $VF sline] >= 0} {
    if {[regexp {^[     ]*\/\*} $sline m]} {set comments true}
    if {[regexp {^[     ]*\*\/} $sline m]} {set comments false}
    if {$comments} {continue}
    if {![regexp {\;} $sline m] && ![regexp {^[     ]*endmodule} $sline m]} {
      set acc_line "$acc_line $sline"; continue
    } else {
      set line [cb "$acc_line $sline"]; set acc_line ""
    }
    # Parsing modules
    #================
    if {[regexp {^[     ]*module[       ]+([^   \(]+)} $line m mod_name]} {
      continue
    } 
    if {[regexp {^[     ]*input[        ]+\((.*)\)[     ]*([^   ;]+)} $line m m1 m2]} {
      regsub -all " " $m1 "" size
      lappend iports $m2\($size\); continue
    }
    if {[regexp {^[     ]*input[        ]+([^\:]+)[     ]*;[    ]*$} $line m m1]} {
      foreach in [split $m1 " ,"] {
        if {$in != ""} {lappend iports $in} 
      }
      continue
    }
    if {[regexp {^[     ]*output[       ]+\((.*)\)[     ]*([^   ;]+)} $line m m1 m2]} {
      regsub -all " " $m1 "" size
      lappend oports $m2\($size\); continue
    }
    if {[regexp {^[     ]*output[       ]+([^\:]+)[     ]*;[    ]*$} $line m m1]} {
      foreach out [split $m1 " ,"] {
        if {$out != ""} {lappend oports $out} 
      }
      continue
    }
    if {[regexp {^[     ]*endmodule} $line m]} {
      db eval "INSERT INTO lib VALUES(\'$mod_name\', \'$iports\', \'$oports\')"
      set iports ""; set oports ""; continue 
    }    
  }
  close $VF
}


#===================================================================

proc parse_file {vfile} {
  if [catch {open $vfile r} VF] {
    puts stderr "Cannot open file $vfile!"
  }
  set acc_line ""; set comments false;
  set iports ""; set oports "";

  while {[gets $VF sline] >= 0} {
    if {[regexp {^[     ]*\/\*} $sline m]} {set comments true}
    if {[regexp {^[     ]*\*\/} $sline m]} {set comments false}
    if {$comments} {continue}
    if {![regexp {\;} $sline m] && ![regexp {^[     ]*endmodule} $sline m]} {
      set acc_line "$acc_line $sline"; continue
    } else {
      set line [cb "$acc_line $sline"]; set acc_line ""
    }
    # Parsing modules
    #================
    if {[regexp {^[     ]*module[       ]+([^   \(]+)} $line m mod_name]} {
      continue
    } 
    if {[regexp {^[     ]*input[        ]+\((.*)\)[     ]*([^   ;]+)} $line m m1 m2]} {
      regsub -all " " $m1 "" size
      lappend iports $m2\($size\); continue
    }
    if {[regexp {^[     ]*input[        ]+([^\:]+)[     ]*;[    ]*$} $line m m1]} {
      foreach in [split $m1 " ,"] {
        if {$in != ""} {lappend iports $in} 
      }
      continue
    }
    if {[regexp {^[     ]*output[       ]+\((.*)\)[     ]*([^   ;]+)} $line m m1 m2]} {
      regsub -all " " $m1 "" size
      lappend oports $m2\($size\); continue
    }
    if {[regexp {^[     ]*output[       ]+([^\:]+)[     ]*;[    ]*$} $line m m1]} {
      foreach out [split $m1 " ,"] {
        if {$out != ""} {lappend oports $out} 
      }
      continue
    }
    if {[regexp {^[     ]*endmodule} $line m]} {
      db eval "INSERT INTO mod(name, inputs, outputs) VALUES(\'$mod_name\', \'$iports\', \'$oports\')"
      set iports ""; set oports ""; continue 
    }    
    # Parsing wires
    #==============
    if {[regexp {^[     ]*wire[     ]+(.+)\;}  $line m wires]} {
      set split_wires [split $wires]
      foreach wire $split_wires {
        if {[regexp {([^ {};,]+)} $wire m wire_name]} {
          db eval "INSERT INTO net(name,pname) VALUES(\'$wire_name\', \'$mod_name\')"
        }
      }
      continue
    }
    # Parsing cells
    #================
    if {[regexp {^[ 	]*([^ 	]+)[ 	]+([^ 	]+)[ 	]+\((.*)\)[ 	]*\;} $line m mname iname all_conn]} {
      regsub -all " " $all_conn "" conn1
      set conn "$conn1,"
      db eval "INSERT INTO inst VALUES(\'$iname\', \'$mname\', \'$mod_name\', \'$conn\')"
    }     

  }
  close $VF
}

#===================================================================
proc read_verilog {vfile} {
  global current
  if {[file extension $vfile] == ".v"} {
    set fname [file rootname $vfile]
    set current ""
    create_db  $fname
    parse_file $vfile
  } else {
    puts "Error: $vfile is not verilog file!"
  }
}
#===================================================================
proc read_lib {vfile} {
  if {[file extension $vfile] == ".v"} {
     parse_lib $vfile
  } else {
    puts "Error: $vfile is not verilog file!"
  }
}
#===================================================================
proc read_db {dbfile} {
  if {[file extension $dbfile] == ".db"} {
    sqlite db $dbfile
  } else {
    puts "Error: $dbfile is not DB file!"
  }
}


#===================================================================
proc write_test {} {
  db eval {SELECT * FROM lib} values1 {parray values1; puts ""}
  db eval {SELECT * FROM mod} values2 {parray values2; puts ""}
  db eval {SELECT * FROM net} values3 {parray values3; puts ""}
  db eval {SELECT * FROM inst} values4 {parray values4; puts ""}
}


#===================================================================
proc get_lib_cells {{regexp *}} {
  regsub -all {\*} $regexp {%} sql_regexp
  return [db eval "SELECT (name) FROM lib WHERE name LIKE '$sql_regexp'"] 
}

#===================================================================
proc get_cells {{regexp *}} {
  global current; check_current
  regsub -all {\*} $regexp {%} sql_regexp
  return [db eval "SELECT (name) FROM inst WHERE name LIKE '$sql_regexp' AND pname=\'$current\'"] 
}

#===================================================================
proc get_modules {{regexp *}} {
  regsub -all {\*} $regexp {%} sql_regexp
  return [db eval "SELECT (name) FROM mod WHERE name LIKE '$sql_regexp'"] 
}

#===================================================================
proc get_nets {{regexp *}} {
  global current; check_current
  regsub -all {\*} $regexp {%} sql_regexp
  return [db eval "SELECT (name) FROM net WHERE name LIKE '$sql_regexp' AND pname=\'$current\'"] 
}

#===================================================================
proc current {args} {
  global current
  if {$args == ""} {
    return $current
  } else {
    if {[get_modules $args] == $args} {
      set current $args
    } else {
      puts "Module $args not found. Valid module names are:\n[get_modules *]"
      return 0
    }
  }
}
   
#===================================================================
proc get_ports {{regexp *} {dir -all} {split ""}} {
  global current; check_current
  if {$dir == "-in"} {
    set values [split [string trim [db eval "SELECT inputs FROM mod WHERE name='$current'"] "{}"]]
  } elseif {$dir == "-out"} {
    set values [split [string trim [db eval "SELECT outputs FROM mod WHERE name='$current'"] "{}"]]
  } elseif {$dir == "-all"} {
    set val1 [split [string trim [db eval "SELECT inputs FROM mod WHERE name='$current'"] "{}"]]
    set val2 [split [string trim [db eval "SELECT outputs FROM mod WHERE name='$current'"] "{}"]]
    set values "$val1 $val2"
  } else {
    puts "Usage: get_ports regexp \[-in/-out\](default: all) \[-split\](default: nosplit)"
    return 0
  }