funcs.tcl

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

  if {$split == "-split"} {
    return [busplit [lget [split $values] $regexp]]   
  } else {
    return [lget [split $values] $regexp]   
  } 
} 

#===================================================================
proc get_pins {name {dir -all} {full ""}} {
  global current; check_current
  set mname [db eval "SELECT mname FROM inst WHERE name='$name' AND pname='[current]'"]
  if {$dir == "-in"} {
    set pins1 [split [string trim [db eval "SELECT inputs FROM lib WHERE name='$mname'"] "{}"]] 
    set pins2 [split [string trim [db eval "SELECT inputs FROM mod WHERE name='$mname'"] "{}"]]
    set ret_list [concat $pins1 $pins2]     
  } elseif {$dir == "-out"} {
    set pins1 [split [string trim [db eval "SELECT outputs FROM lib WHERE name='$mname'"] "{}"]] 
    set pins2 [split [string trim [db eval "SELECT outputs FROM mod WHERE name='$mname'"] "{}"]]
    set ret_list [concat $pins1 $pins2]     
  } elseif {$dir == "-all"} {
    set pins1 [split [string trim [db eval "SELECT inputs FROM lib WHERE name='$mname'"] "{}"]] 
    set pins2 [split [string trim [db eval "SELECT outputs FROM lib WHERE name='$mname'"] "{}"]] 
    set pins3 [split [string trim [db eval "SELECT inputs FROM mod WHERE name='$mname'"] "{}"]] 
    set pins4 [split [string trim [db eval "SELECT outputs FROM mod WHERE name='$mname'"] "{}"]] 
    set ret_list [concat $pins1 $pins2 $pins3 $pins4]
  } else {
    puts "Valid direction values: -in, -out or -all (default)" 
    return 0
  }
  if {$full == "-full"} {
    set full_list ""
    foreach pin $ret_list {
      lappend full_list "$name/$pin"
    }
    return $full_list
  } else {
    return $ret_list
  }
}


#===================================================================
proc get_lib_pins {name {dir -all}} {
  if {$dir == "-in"} {
    set pins [db eval "SELECT inputs FROM lib WHERE name='$name'"]
  } elseif {$dir == "-out"} {
    set pins [db eval "SELECT outputs FROM lib WHERE name='$name'"]
  } elseif {$dir == "-all"} {
    set pins1 [split [string trim [db eval "SELECT inputs FROM lib WHERE name='$name'"] "{}"]] 
    set pins2 [split [string trim [db eval "SELECT outputs FROM lib WHERE name='$name'"] "{}"]] 
    set pins "$pins1 $pins2"
  } else {
    puts "Usage: get_lib_pins regexp \[-in/-out\](default: all)"
    return 0
  }
  return [split [string trim $pins "{}"]] 
}

#===================================================================
proc get_mname {name} {
  global current; check_current
  return [db eval "SELECT mname FROM inst WHERE name='$name' AND pname='$current'"]
}  


#===================================================================
proc get_cnet {pin_name {bit "no"}} {
  global current; check_current
  if {[regexp {^(.*)/([^/]+)$} $pin_name m parent pin]} {  
    set conn [db eval "SELECT conn FROM inst WHERE name='$parent' AND pname='$current'"]
    if {[regexp {^([^\(]+)\(([^\:]+)\:([^\)]+)\)} $pin m pname n1 n2]} {
      set nmin [min $n1 $n2]; set nmax [max $n1 $n2]
      if {$bit <= $nmax && $bit >= $nmin} {
	set exp "\.$pname\\\(\\\{\(\[\^\\\}\]\+\)\\\}\\\)\\\,"
        if {[regexp $exp $conn m cnets_str]} {
          set cnets [split $cnets_str ,]
	  if {$n1 > $n2} {
            return [lindex $cnets [expr $n1 -$bit]]
          } else {
            return [lindex $cnets [expr $bit -$n2]]             
          }
        }
      } else {
        puts "Error: Bit value is not set or out of range for current port/pin!"
        return "" 
      }    
    } else {
      set exp "\.$pin\\\(\(\[\^\\\,\\\{\]\+\)\\\)\\\,"
      if {[regexp $exp $conn m cnet]} {
        return $cnet
      } else {
        return ""
      } 
    }
  } elseif {[get_ports $pin_name] != ""} {
    if {$bit == "no"} {
      return $pin_name
    } else {
      if {[regexp {^([^\(]+)\(([^\:]+)\:([^\)]+)\)} $pin_name m pin n1 n2]} {
        if {$bit <= [max $n1 $n2] && $bit >= [min $n1 $n2]} {      
          return "$pin\($bit\)"
        } else {
          puts "Error: Bit value is not set or out of range for current port/pin!"
          return "" 
        }
      }
    }
  } else {
    puts "Error in pin name; use following format: U809/A"
    return ""
  }
}

#===================================================================
proc get_cpins {net_name {dir -all}} {
  global current; check_current
  set conn [db eval "SELECT name, conn FROM inst WHERE conn LIKE '%$net_name%' AND pname='$current'"]
  set ret_list ""
  for {set i 0} {$i < [llength $conn]} {incr i 2} {
    set iname [lindex $conn $i]

    regsub {\(} $net_name "\\\(" nname1 
    regsub {\)} $nname1 "\\\)" nname2 

    set exp "\\\.\(\[\^\(\]\+\)\\\($nname2\\\)" 
    if {[regexp $exp [lindex $conn [expr $i + 1]] m pin]} {
      if {$dir == "-in" && [lsearch -exact [get_pins $iname -in] $pin] >= 0 } {
        lappend ret_list "$iname/$pin"
      }
      if {$dir == "-out" && [lsearch -exact [get_pins $iname -out] $pin] >= 0 } {
        lappend ret_list "$iname/$pin"
      }
      if {$dir == "-all"} {
        lappend ret_list "$iname/$pin"
      }
    }
  }
  return $ret_list
}    

#===================================================================
proc get_submodules {{regexp *} {type -all}} {
  global current; check_current
  regsub -all {\*} $regexp {%} sql_regexp
  set lst [unique [db eval "SELECT mname FROM inst WHERE mname LIKE \
     '$sql_regexp' AND pname='$current'"]]
  set ret_list ""
  foreach name $lst {
    if {$type == "-lib" && [get_lib_cells $name] != ""} {
      lappend ret_list $name 
    } elseif {$type == "-mod" && [get_modules $name] != ""} {
      lappend ret_list $name 
    } elseif {$type == "-all"} {
      lappend ret_list $name
    }
  }
  return $ret_list     
}


#===================================================================
proc literate {} {
  global current; check_current
  set lmods [get_submodules * -lib]
  set hmods [get_submodules * -mod]
  set all_modules [concat $lmods $hmods]
  set nolink [ldelete [get_submodules] $all_modules]
  if {$nolink != ""} {
    puts "Error linking the following submodules of $current:\n$nolink"
    return 0
  } else {
    foreach hmod $hmods {
      db eval "UPDATE mod SET pname='$current' WHERE name='$hmod'"
      current $hmod
      literate
    }
  }
  return 1   
}
#===================================================================
proc link {} {
  global current; check_current
  set cur_module [current]
  literate
  current $cur_module
  return 1
}
  
#===================================================================
proc hiterate {} {
  global current, hname
  foreach smod [get_submodules * -mod] {
    set hname($smod) "$hname([current]).$smod"
    puts $hname($smod)
    current $smod
    hiterate
  }
}

#===================================================================
proc get_hier {} {
  global current, hname
  check_current
  set curr_module [current]
  if [info exists hname] {unset hname}
  set hname([current]) ".[current]"
  puts ".[current]"
  hiterate
  current $curr_module
}

#===================================================================
proc ihiterate {} {
  global current, hname
  set smods [get_submodules * -mod]
  foreach cell [get_cells *] {
    set mname [get_mname $cell]
    if {[lget $smods $mname] != ""} {     
      set hname($mname) "$hname([current]).$cell"
      puts $hname($mname)
      current $mname
      ihiterate
    }
  }
}

#===================================================================
proc get_ihier {} {
  global current, hname
  check_current
  set curr_module [current]
  if [info exists hname] {unset hname}
  set hname([current]) ".[current]"
  puts ".[current]"
  ihiterate
  current $curr_module
}

#===================================================================
proc gui_hiterate {} {
  global current, hname
  set cur_mod [current]
  foreach smod [get_submodules * -mod] {
    set hname($smod) "$hname($cur_mod).$smod"
    current $smod
    if {[get_submodules * -mod] != ""} {
      $Tree::tree insert end $hname($cur_mod) $hname($smod) -text $smod \
      -image [Bitmap::get folder] -drawcross auto -data $smod
    } else {
      $Tree::tree insert end $hname($cur_mod) $hname($smod) -text $smod \
      -image [Bitmap::get file] -drawcross auto -data $smod
    }   
    gui_hiterate
  }
}

#===================================================================
proc get_gui_hier {} {
  global current, hname
  check_current
  set curr_module [current]
  if [info exists hname] {unset hname}
  set top_mod [current]
  set hname($top_mod) ".$top_mod"
  $Tree::tree insert end root .$top_mod -text $top_mod -data $top_mod -open 1 \
        -image [Bitmap::get openfold]
  gui_hiterate
  current $curr_module
}


# Remove commands:

# 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


#===================================================================
proc rm_lib_cell {name} {
  if {[get_lib_cells $name] != ""} {
    db eval "DELETE FROM lib WHERE name='$name'"
    return 1
  } else {
    puts "Error: library cell $name doesn't exist!"
    return 0
  }
}

#===================================================================
proc rm_mod {name} {
  if {[get_modules $name] != ""} {
    db eval "DELETE FROM mod WHERE name='$name'"
    return 1
  } else {
    puts "Error: Module $name doesn't exist!"
    return 0
  }
}

#===================================================================
proc rm_cell {name} {
  global current; check_current
  if {[get_cells $name] != ""} {
    db eval "DELETE FROM inst WHERE name='$name' AND pname=\'$current\'"
    return 1
  } else {
    puts "Error: cell $name doesn't exist!"
    return 0
  }
}
  
#===================================================================
proc rm_net {net_name} {
  global current; check_current
  if {[get_nets $net_name] != ""} {
    set retval 1
    db eval "DELETE FROM net WHERE name='$net_name' AND pname=\'$current\'"
    set clist [db eval "SELECT name, conn FROM inst WHERE conn LIKE '%$net_name%' AND pname='$current'"]
    if {$clist != ""} {
      for {set i 0} {$i < [llength $clist]} {incr i 2} {
        set iname [lindex $clist $i]
        regsub -all $net_name [lindex $clist [expr $i + 1]] "" new_conn
        db eval "UPDATE inst SET conn='$new_conn' WHERE name='$iname' AND pname='$current'" 
      }
    }
  } else {
    set retval 0
    puts "Error: net $net_name not found in current design!"
  }
  return $retval
}

#===================================================================
proc rm_port {name} {
  global current; check_current
  if {[get_ports $name] != ""} {
    set retval 1
    set iports [db eval "SELECT inputs FROM mod WHERE name='$current'"] 
    set oports [db eval "SELECT outputs FROM mod WHERE name='$current'"] 
    regsub {\(} $name "\\\(" name1 
    regsub {\)} $name1 "\\\)" name2
    if {![regexp {(.+)\(} $name m sname]} {set sname $name}
    if {[regsub "$name2 " $iports "" new_iports]} {
      db eval "UPDATE mod SET inputs='$new_iports' WHERE name='$current'"
    }
    if {[regsub "$name2 " $oports "" new_oports]} {
      db eval "UPDATE mod SET outputs='$new_oports' WHERE name='$current'"
    }
    set clist [db eval "SELECT name, conn FROM inst WHERE conn LIKE '%$sname%' AND pname='$current'"]
    if {$clist != ""} {
      for {set i 0} {$i < [llength $clist]} {incr i 2} {
        set iname [lindex $clist $i]
        regsub -all "$sname\\\(\[\^\\\)\]\+\\\)" [lindex $clist [expr $i + 1]] "" new_conn
        db eval "UPDATE inst SET conn='$new_conn' WHERE name='$iname' AND pname='$current'" 
      }
    }
  } else {
    set retval 0
    puts "Error: port $name not found in current design!"
  }
  return $retval
}

#===================================================================
# proc new_cell {name lib_name} {
  




# source nshell.tcl
# read_verilog i2c.v
# read_lib lib.v
# current i2c