package require nx::test proc direct-constraints {obj} { set constraints "" foreach c [$obj info precedence] { set sc [$c info superclass] # add constraints to ensure that subclass is before superclass foreach super $sc { lappend constraints [list $c < $super] } # maintain order from superclass list if {[llength $sc] == 2} { lappend constraints [list [lindex $sc 0] < [lindex $sc 1]] } elseif {[llength $sc] > 2} { set first [lindex $sc 0] foreach class [lrange $sc 1 end] { lappend constraints [list $first < $class] set first $class } } } return $constraints } proc monotonicity-constraints {obj {linearizer ""}} { set constraints "" foreach c [$obj info precedence] { # compute for every class its own heritage and turn this into constraints if {$linearizer eq ""} { set sc [$c info heritage] } else { puts "call linearizer [list $linearizer $c]" set sc [$linearizer $c] } # maintain order from superclass list if {[llength $sc] == 2} { lappend constraints [list [lindex $sc 0] < [lindex $sc 1]] } elseif {[llength $sc] > 2} { set first [lindex $sc 0] foreach class [lrange $sc 1 end] { lappend constraints [list $first < $class] set first $class } } } return [lsort -unique $constraints] } proc local-order-constraints {obj} { # no class before its subclass set constraints "" foreach c [$obj info precedence] { # compute vor every class its subclasses set subclasses [$c info subclass -closure] # subclasses must be before classes foreach sc $subclasses { lappend constraints [list $sc < $c] } } return [lsort -unique $constraints] } proc check-constraints {example rule kind list constraints} { #puts "check-constraints $example $rule $kind $list" foreach triple $constraints { lassign $triple x before y set larger [expr {[lsearch -exact $list $x] > [lsearch -exact $list $y]}] ? [list set _ $larger] 0 "$example $rule $kind violated $triple" } #puts "" } nx::test case boat { # # Boat example DHHM 94; # R. Ducournau, M. Habib, M. Huchard, and M.L. Mugnier. Proposal for a Monotonic Multiple Inheritance Linearization. # see: http://www2.lirmm.fr/~ducour/Publis/DHHM-oopsla94.pdf # nx::Class create boat ;# 8 nx::Class create dayboat -superclass boat ;# 6 nx::Class create wheelboat -superclass boat ;# 7 nx::Class create engineless -superclass dayboat ;# 3 nx::Class create pedalwheelboat -superclass {engineless wheelboat} ;# 2 nx::Class create smallmultihull -superclass dayboat ;# 5 nx::Class create smallcatamaran -superclass smallmultihull ;# 4 nx::Class create pedalo -superclass {pedalwheelboat smallcatamaran};# 1 dayboat public method max-distance {} {return 5m} wheelboat public method max-distance {} {return 100m} # If the linearization is known to be monotonic, the compiler can # choose to dispatch the call to max-distance directly to the method # defined on . This is known statically because no new # methods can be defined on max-distance - it is sealed - and # is always more specific than for instances # of . pedalo create o1 #? {o1 info precedence} {::pedalo ::pedalwheelboat ::engineless ::wheelboat ::smallcatamaran ::smallmultihull ::dayboat ::boat ::nx::Object} #? {o1 max-distance} 100m ? {o1 info precedence} {::pedalo ::pedalwheelboat ::engineless ::smallcatamaran ::smallmultihull ::dayboat ::wheelboat ::boat ::nx::Object} ? {o1 max-distance} 5m pedalwheelboat create pwb ? {pwb max-distance} 5m ? {pwb info precedence} "::pedalwheelboat ::engineless ::dayboat ::wheelboat ::boat ::nx::Object" smallcatamaran create smc ? {smc max-distance} 5m ? {smc info precedence} "::smallcatamaran ::smallmultihull ::dayboat ::boat ::nx::Object" set order [o1 info precedence] puts "${:case} nx: $order" check-constraints ${:case} nx direct $order [direct-constraints o1] check-constraints ${:case} nx monotonicty $order [monotonicity-constraints o1] check-constraints ${:case} nx local-order $order [local-order-constraints o1] } # # Local variables: # mode: tcl # tcl-indent-level: 2 # indent-tabs-mode: nil # End: