Changeset 64


Ignore:
Timestamp:
Aug 2, 2002, 8:50:36 AM (15 years ago)
Author:
kevin
Message:

Use SystemStarter style dependency model.
Allows for hard (requires) and soft (uses) dependencies.

Location:
trunk/base/Tcl/port1.0
Files:
7 edited

Legend:

Unmodified
Added
Removed
  • trunk/base/Tcl/port1.0/portchecksum.tcl

    r58 r64  
    33package require portutil 1.0
    44
    5 register_target checksum portchecksum::main main fetch
     5register target checksum portchecksum::main
     6register requires checksum main fetch
     7
    68namespace eval portchecksum {
    79        variable options
  • trunk/base/Tcl/port1.0/portconfigure.tcl

    r53 r64  
    33package require portutil 1.0
    44
    5 register_target configure portconfigure::main main fetch extract checksum patch
     5register target configure portconfigure::main
     6register requires configure main fetch extract checksum patch
     7
    68namespace eval portconfigure {
    79        variable options
  • trunk/base/Tcl/port1.0/portextract.tcl

    r57 r64  
    33package require portutil 1.0
    44
    5 register_target extract portextract::main main fetch checksum
     5register target extract portextract::main
     6register requires extract fetch checksum
     7
    68namespace eval portextract {
    79        variable options
  • trunk/base/Tcl/port1.0/portfetch.tcl

    r55 r64  
    33package require portutil 1.0
    44
    5 register_target fetch portfetch::main main
     5register target fetch portfetch::main
     6register requires fetch main
     7
    68namespace eval portfetch {
    79        variable options
  • trunk/base/Tcl/port1.0/portmain.tcl

    r59 r64  
    55package require portutil 1.0
    66
    7 register_target main portmain::main
     7register target main portmain::main
    88namespace eval portmain {
    99        variable options
  • trunk/base/Tcl/port1.0/portpatch.tcl

    r62 r64  
    33package require portutil 1.0
    44
    5 register_target patch portpatch::main main fetch checksum extract
     5register target patch portpatch::main
     6register requires patch main fetch checksum extract
     7
    68namespace eval portpatch {
    79        variable options
  • trunk/base/Tcl/port1.0/portutil.tcl

    r61 r64  
    1010########### External High Level Procedures ###########
    1111
    12 # register_target
     12# register
    1313# Creates a target in the global target list using the internal dependancy
    1414#     functions
    15 # Arguments: <target name> <procedure to execute> <dependency list>
    16 proc register_target {target procedure args} {
    17         if {[is_depend portutil::targets $target]} {
    18                 puts "Warning: target '$target' re-registered (new procedure: '$procedure')"
    19         }
    20         if {[llength $args] == 0} {
    21                 add_depend portutil::targets $target $procedure
    22         } else {
    23                 eval "add_depend portutil::targets $target $procedure $args"
     15# Arguments: target <target name> <procedure to execute>
     16# Arguments: requires <list of target names>
     17# Arguments: uses <list of target names>
     18proc register {mode target args} {     
     19        if {[string equal target $mode]} {
     20                if {[isval portutil::targets $target]} {
     21                        # XXX: remove puts
     22                        puts "Warning: target '$target' re-registered (new procedure: '$procedure')"
     23                }
     24                depend_list_add_item portutil::targets $target $args [list] [list]
     25        } else {
     26                # requires or uses or whatever ;-)
     27                if {[isval portutil::targets name,$target]} {
     28                        # XXX: violates data abstraction
     29                        eval "lappend portutil::targets($mode,$target) $args"
     30                } else {
     31                        # XXX: remove puts
     32                        puts "Warning: target '$target' not-registered in register $mode"
     33                }
    2434        }
    2535}
    2636
    2737proc deregister_target {target} {
    28                 del_depend portutil::targets $target
     38        depend_list_del_item portutil::targets portutil::targets $target
    2939}
    3040
     
    6373########### Dependancy Manipulation Procedures ###########
    6474
    65 # add dependancy
    66 # Will overwrite entries for the same target
    67 # Expects arguments: array, target, procedure, depends (optional)
    68 proc add_depend {array target procedure args} {
    69         upvar $array uparray
    70         if {![isval uparray procedure,$target]} {
    71                 lappend uparray(targets) $target
    72         }
    73         setval uparray procedure,$target $procedure
    74         if {[llength $args] > 0} {
    75                 setval uparray depends,$target $args
    76         }
    77 }
    78 
    79 # del dependancy
    80 proc del_depend {array target} {
    81         upvar $array uparray
    82         set uparray(targets) [ldelete uparray(targets) $target]
    83         delval uparray procedure,$target
    84         if {[isval uparray depends,$target]} {
    85                 delval uparray depends,$target
    86         }
    87 }
    88 
    89 proc is_depend {array target} {
    90         upvar $array uparray
    91         return [isval uparray procedure,$target]
    92 }
    93 
    94 
    95 # XXX Well, it works. Could be faster.
    96 proc eval_depend {array} {
    97         upvar $array uparray
    98         set list $uparray(targets)
    99         set slist $uparray(targets)
    100         set i 0
    101         set j [llength $list]
    102         while {$i < $j} {
    103                 set target [lindex $slist $i]
    104                 if {[isval uparray depends,$target]} {
    105                         set depends [getval uparray depends,$target]
    106                         set k [llength $depends]
    107                         set l 0
    108                         while {$l < $k} {
    109                                 set depend [lindex $depends $l]
    110                                 if {[lsearch -exact $list $depend] == -1} {
    111                                         puts "Missing dependancy '$depend'"
    112                                         return -1
    113                                 }
    114                                 set curloc [lsearch -exact $list $target]
    115                                 set newloc [lsearch -exact $list $depend]
    116                                 if {$curloc < $newloc} {
    117                                         set list [lreplace $list $curloc $curloc]
    118                                         set list [linsert $list $newloc $target]
    119                                 }
    120                                 incr l
     75# depend_list_add
     76# Creates a new node in the dependency list with the given name.
     77# Optionally sets the list of hard and soft dependencies.
     78# Caution: this will over-write an existing node of the same name.
     79proc depend_list_add_item {nodes name procedure requires uses} {
     80        upvar $nodes upnodes
     81        set upnodes(name,$name) $name
     82        set upnodes(procedure,$name) $procedure
     83        set upnodes(requires,$name) $requires
     84        set upnodes(uses,$name) $uses
     85}
     86
     87proc depend_list_del_item {nodes name} {
     88        upvar $nodes upnodes
     89        unset upnodes(name,$name)
     90        unset upnodes(procedure,$name)
     91        unset upnodes(requires,$name)
     92        unset upnodes(uses,$name)
     93}
     94
     95# Count the unmet dependencies in the sublist
     96# (private)
     97proc depend_list_count_unmet {names statusdict} {
     98        upvar $statusdict upstatusdict
     99        set unmet 0
     100        foreach name $names {
     101                if {![isval upstatusdict $name] ||
     102                    ![string equal $upstatusdict($name) success]} {
     103                        incr unmet
     104                }
     105        }
     106        return $unmet
     107}
     108
     109# Returns true of any of the dependencies are pending in the waitlist
     110# (private)
     111proc depend_list_has_pending {waitlist uses} {
     112        foreach name $uses {
     113                if {[isval $waitlist name,$name]} {
     114                        return 1
     115                }
     116        }
     117        return 0
     118}
     119
     120# Get the next item from the depend list
     121# (private)
     122proc depend_list_get_next {waitlist statusdict} {
     123        set nextitem ""
     124        # arbitrary large number ~ INT_MAX
     125        set minfailed 2000000000
     126        upvar $waitlist upwaitlist
     127        upvar $statusdict upstatusdict
     128
     129        foreach n [array names upwaitlist name,*] {
     130                set name $upwaitlist($n)
     131
     132                # skip if unsatisfied hard dependencies
     133                if {[depend_list_count_unmet $upwaitlist(requires,$name) upstatusdict]} { continue }
     134
     135                # favor item with fewest unment soft dependencies
     136                set unmet [depend_list_count_unmet $upwaitlist(uses,$name) upstatusdict]
     137
     138                # delay items with unmet soft dependencies that can be filled
     139                if {$unmet > 0 && [depend_list_has_pending waitlist $upwaitlist(uses,$name)]} { continue }
     140
     141                if {$unmet >= $minfailed} {
     142                        # not better than our last pick
     143                        continue
     144                } else {
     145                        # better than our last pick
     146                        set minfailed $unmet
     147                        set nextitem $name
     148                }
     149        }
     150        return $nextitem
     151}
     152
     153
     154# Evaluate the dependency list, returning an ordered list suitable
     155# for execution.
     156proc eval_depend {nodes} {
     157        # waitlist - nodes waiting to be executed
     158        upvar $nodes waitlist
     159
     160        # status - keys will be node names, values will be success or failure.
     161        array set statusdict [list]
     162               
     163        # loop for as long as there are nodes in the waitlist.
     164        while (1) {
     165                set name [depend_list_get_next waitlist statusdict]
     166                if {[isval waitlist procedure,$name]} {
     167                        # XXX: remove puts
     168                        puts "DEBUG: Executing $name"
     169                        if {[$waitlist(procedure,$name) $waitlist(name,$name)] == 0} {
     170                                array set statusdict [list $name success]
     171                        } else {
     172                                # XXX: remove puts
     173                                puts "Error in $name"
     174                                array set statusdict [list $name failure]
    121175                        }
     176                        array unset waitlist name,$name
     177                        array unset waitlist procedure,$name
     178                        array unset waitlist requires,$name
     179                        array unset waitlist uses,$name
    122180                } else {
    123                         set curloc [lsearch -exact $list $target]
    124                         set list [lreplace $list $curloc $curloc]
    125                         set list [linsert $list 0 $target]
    126                 }
    127                 incr i
    128         }
    129         set uparray(targets) $list
    130         foreach target $uparray(targets) {
    131                 if {[info exists uparray(depends,$target)]} {
    132                         foreach depend $uparray(depends,$target) {
    133                                 if {[info exists finished]} {
    134                                         if {[lsearch $finished $depend] == -1} {
    135                                                 puts "Cyclic dependencies between '$target' and dependancy '$depend'"
    136                                                 return -1
    137                                         }
    138                                 }
     181                        # somebody broke!
     182                        # XXX: remove puts
     183                        puts "Warning: the following targets did not execute: "
     184                        foreach name [array names waitlist name,*] {
     185                                puts -nonewline "$waitlist($name) "
    139186                        }
    140                 }
    141                 if {[$uparray(procedure,$target) $target] == 0} {
    142                         lappend finished $target
    143                 } else {
    144                         puts "Error in target '$target'"
    145                         return -1
    146                 }
    147         }
    148         return 0
     187                        puts ""
     188                        break
     189                }
     190        }
     191       
    149192}
    150193
Note: See TracChangeset for help on using the changeset viewer.