Index: generic/predefined.h =================================================================== diff -u -rfad871fc9a27570119d6bf9dbed84b7469701bd6 -rc11ab22190bdfe6231b454e9969b6ffafb547f9c --- generic/predefined.h (.../predefined.h) (revision fad871fc9a27570119d6bf9dbed84b7469701bd6) +++ generic/predefined.h (.../predefined.h) (revision c11ab22190bdfe6231b454e9969b6ffafb547f9c) @@ -1,5 +1,6 @@ static char cmd[] = -"# first we create the ::xotcl2 object system.\n" +"#\n" +"set bootstrap 1\n" "namespace eval xotcl2 {\n" "namespace path ::xotcl\n" "::xotcl::createobjectsystem ::xotcl2::Object ::xotcl2::Class\n" @@ -19,24 +20,24 @@ "error \"[self]: unable to dispatch method '$m'\"}}\n" "Object method init args {}\n" "Object method objectparameter {} {;}\n" -"Class create ParameterType\n" +"Class create ::xotcl2::ParameterType\n" "foreach cmd [info command ::xotcl::cmd::ParameterType::*] {\n" -"::xotcl::alias ParameterType [namespace tail $cmd] $cmd}\n" -"ParameterType create parameterType\n" -"Object create objectInfo\n" -"Object create classInfo\n" +"::xotcl::alias ::xotcl2::ParameterType [namespace tail $cmd] $cmd}\n" +"::xotcl2::ParameterType create ::xotcl2::parameterType\n" +"Object create ::xotcl2::objectInfo\n" +"Object create ::xotcl2::classInfo\n" "foreach cmd [info command ::xotcl::cmd::ObjectInfo::*] {\n" -"::xotcl::alias objectInfo [namespace tail $cmd] $cmd\n" -"::xotcl::alias classInfo [namespace tail $cmd] $cmd}\n" +"::xotcl::alias ::xotcl2::objectInfo [namespace tail $cmd] $cmd\n" +"::xotcl::alias ::xotcl2::classInfo [namespace tail $cmd] $cmd}\n" "foreach cmd [info command ::xotcl::cmd::ClassInfo::*] {\n" -"::xotcl::alias classInfo [namespace tail $cmd] $cmd}\n" +"::xotcl::alias ::xotcl2::classInfo [namespace tail $cmd] $cmd}\n" "unset cmd\n" -"::xotcl::alias objectInfo is ::xotcl::is\n" -"::xotcl::alias classInfo is ::xotcl::is\n" -"::xotcl::alias classInfo classparent ::xotcl::cmd::ObjectInfo::parent\n" -"::xotcl::alias classInfo classchildren ::xotcl::cmd::ObjectInfo::children\n" -"Object instforward info -onerror ::xotcl::infoError ::xotcl::objectInfo %1 {%@2 %self}\n" -"Class instforward info -onerror ::xotcl::infoError ::xotcl::classInfo %1 {%@2 %self}\n" +"::xotcl::alias ::xotcl2::objectInfo is ::xotcl::is\n" +"::xotcl::alias ::xotcl2::classInfo is ::xotcl::is\n" +"::xotcl::alias ::xotcl2::classInfo classparent ::xotcl::cmd::ObjectInfo::parent\n" +"::xotcl::alias ::xotcl2::classInfo classchildren ::xotcl::cmd::ObjectInfo::children\n" +"Object instforward info -onerror ::xotcl::infoError ::xotcl2::objectInfo %1 {%@2 %self}\n" +"Class instforward info -onerror ::xotcl::infoError ::xotcl2::classInfo %1 {%@2 %self}\n" "proc ::xotcl::infoError msg {\n" "regsub -all \" \" $msg \"\" msg\n" "regsub -all \" \" $msg \"\" msg\n" @@ -62,32 +63,32 @@ "error \"unknown info option \\\"$method\\\"; [.info info]\"}\n" "namespace export Object Class}\n" "namespace eval ::xotcl {\n" -"::xotcl::createobjectsystem ::xotcl::Object ::xotcl::Class}\n" -"set bootstrap 1\n" +"::xotcl::createobjectsystem ::xotcl::Object ::xotcl::Class\n" "foreach cmd [info command ::xotcl::cmd::Object::*] {\n" -"::xotcl::alias ::xotcl::Object [namespace tail $cmd] $cmd}\n" +"::xotcl::alias Object [namespace tail $cmd] $cmd}\n" "foreach cmd {array append eval incr lappend set subst unset trace} {\n" -"::xotcl::alias ::xotcl::Object $cmd -objscope ::$cmd}\n" +"::xotcl::alias Object $cmd -objscope ::$cmd}\n" "foreach cmd [info command ::xotcl::cmd::Class::*] {\n" -"::xotcl::alias ::xotcl::Class [namespace tail $cmd] $cmd}\n" -"::xotcl::methodproperty ::xotcl::Object destroy static true\n" -"::xotcl::methodproperty ::xotcl::Class alloc static true\n" -"::xotcl::methodproperty ::xotcl::Class dealloc static true\n" -"::xotcl::methodproperty ::xotcl::Class create static true\n" -"::xotcl::Class method unknown {args} {\n" +"::xotcl::alias Class [namespace tail $cmd] $cmd}\n" +"unset cmd\n" +"::xotcl::methodproperty Object destroy static true\n" +"::xotcl::methodproperty Class alloc static true\n" +"::xotcl::methodproperty Class dealloc static true\n" +"::xotcl::methodproperty Class create static true\n" +"Class method unknown {args} {\n" "eval my create $args}\n" -"::xotcl::Object method unknown {m args} {\n" +"Object method unknown {m args} {\n" "if {![self isnext]} {\n" "error \"[self]: unable to dispatch method '$m'\"}}\n" -"::xotcl::Object method init args {}\n" -"::xotcl::Object method objectparameter {} {;}\n" -"::xotcl::Class create ::xotcl::ParameterType\n" +"Object method init args {}\n" +"Object method objectparameter {} {;}\n" +"Class create ::xotcl::ParameterType\n" "foreach cmd [info command ::xotcl::cmd::ParameterType::*] {\n" "::xotcl::alias ::xotcl::ParameterType [namespace tail $cmd] $cmd}\n" "::xotcl::alias ::xotcl::ParameterType type=switch ::xotcl::cmd::ParameterType::type=boolean\n" "::xotcl::ParameterType create ::xotcl::parameterType\n" -"::xotcl::Object create ::xotcl::objectInfo\n" -"::xotcl::Object create ::xotcl::classInfo\n" +"Object create ::xotcl::objectInfo\n" +"Object create ::xotcl::classInfo\n" "foreach cmd [info command ::xotcl::cmd::ObjectInfo::*] {\n" "::xotcl::alias ::xotcl::objectInfo [namespace tail $cmd] $cmd\n" "::xotcl::alias ::xotcl::classInfo [namespace tail $cmd] $cmd}\n" @@ -98,30 +99,30 @@ "::xotcl::alias ::xotcl::classInfo is ::xotcl::is\n" "::xotcl::alias ::xotcl::classInfo classparent ::xotcl::cmd::ObjectInfo::parent\n" "::xotcl::alias ::xotcl::classInfo classchildren ::xotcl::cmd::ObjectInfo::children\n" -"::xotcl::Object instforward info -onerror ::xotcl::infoError ::xotcl::objectInfo %1 {%@2 %self}\n" -"::xotcl::Class instforward info -onerror ::xotcl::infoError ::xotcl::classInfo %1 {%@2 %self}\n" +"Object instforward info -onerror ::xotcl::infoError ::xotcl::objectInfo %1 {%@2 %self}\n" +"Class instforward info -onerror ::xotcl::infoError ::xotcl::classInfo %1 {%@2 %self}\n" "proc ::xotcl::infoError msg {\n" "regsub -all \" \" $msg \"\" msg\n" "regsub -all \" \" $msg \"\" msg\n" "regsub {\\\"} $msg \"\\\"info \" msg\n" "error $msg \"\"}\n" -"::xotcl::objectInfo method info {obj} {\n" +"objectInfo method info {obj} {\n" "set methods [list]\n" "foreach m [::info commands ::xotcl::objectInfo::*] {\n" "set name [namespace tail $m]\n" "if {$name eq \"unknown\"} continue\n" "lappend methods $name}\n" "return \"valid options are: [join [lsort $methods] {, }]\"}\n" -"::xotcl::objectInfo method unknown {method args} {\n" +"objectInfo method unknown {method args} {\n" "error \"unknown info option \\\"$method\\\"; [.info info]\"}\n" -"::xotcl::classInfo method info {cl} {\n" +"classInfo method info {cl} {\n" "set methods [list]\n" "foreach m [::info commands ::xotcl::classInfo::*] {\n" "set name [namespace tail $m]\n" "if {$name eq \"unknown\"} continue\n" "lappend methods $name}\n" "return \"valid options are: [join [lsort $methods] {, }]\"}\n" -"::xotcl::classInfo method unknown {method args} {\n" +"classInfo method unknown {method args} {\n" "error \"unknown info option \\\"$method\\\"; [.info info]\"}\n" "# info instargs\n" "# istype\n" @@ -151,52 +152,51 @@ "set default \"\"\n" "return 0}}\n" "error \"procedure \\\"$method\\\" doesn't have an argument \\\"$varName\\\"\"}\n" -"::xotcl::classInfo method instargs {o method} {::xotcl::info_args inst $o $method}\n" -"::xotcl::classInfo method args {o method} {::xotcl::info_args \"\" $o $method}\n" -"::xotcl::objectInfo method args {o method} {::xotcl::info_args \"\" $o $method}\n" -"::xotcl::classInfo method instnonposargs {o method} {::xotcl::info_nonposargs inst $o $method}\n" -"::xotcl::classInfo method nonposargs {o method} {::xotcl::info_nonposargs \"\" $o $method}\n" -"::xotcl::objectInfo method nonposargs {o method} {::xotcl::info_nonposargs \"\" $o $method}\n" -"::xotcl::classInfo method instdefault {o method arg var} {::xotcl::info_default inst $o $method $arg $var}\n" -"::xotcl::classInfo method default {o method arg var} {::xotcl::info_default \"\" $o $method $arg $var}\n" -"::xotcl::objectInfo method default {o method arg var} {::xotcl::info_default \"\" $o $method $arg $var}\n" -"::xotcl::Object method isobject {{object:substdefault \"[self]\"}} {::xotcl::is $object object}\n" -"::xotcl::Object method isclass {{class:substdefault \"[self]\"}} {::xotcl::is $class class}\n" -"::xotcl::Object method ismetaclass {{class:substdefault \"[self]\"}} {::xotcl::is $class metaclass}\n" -"::xotcl::Object method ismixin {class} {::xotcl::is [self] mixin $class}\n" -"::xotcl::Object method istype {class} {::xotcl::is [self] type $class}\n" -"::xotcl::Object method proc {name arglist body precondition:optional postcondition:optional} {\n" +"classInfo method instargs {o method} {::xotcl::info_args inst $o $method}\n" +"classInfo method args {o method} {::xotcl::info_args \"\" $o $method}\n" +"objectInfo method args {o method} {::xotcl::info_args \"\" $o $method}\n" +"classInfo method instnonposargs {o method} {::xotcl::info_nonposargs inst $o $method}\n" +"classInfo method nonposargs {o method} {::xotcl::info_nonposargs \"\" $o $method}\n" +"objectInfo method nonposargs {o method} {::xotcl::info_nonposargs \"\" $o $method}\n" +"classInfo method instdefault {o method arg var} {::xotcl::info_default inst $o $method $arg $var}\n" +"classInfo method default {o method arg var} {::xotcl::info_default \"\" $o $method $arg $var}\n" +"objectInfo method default {o method arg var} {::xotcl::info_default \"\" $o $method $arg $var}\n" +"Object method isobject {{object:substdefault \"[self]\"}} {::xotcl::is $object object}\n" +"Object method isclass {{class:substdefault \"[self]\"}} {::xotcl::is $class class}\n" +"Object method ismetaclass {{class:substdefault \"[self]\"}} {::xotcl::is $class metaclass}\n" +"Object method ismixin {class} {::xotcl::is [self] mixin $class}\n" +"Object method istype {class} {::xotcl::is [self] type $class}\n" +"Object method proc {name arglist body precondition:optional postcondition:optional} {\n" "set cmd [list my method $name $arglist $body]\n" "if {[info exists precondition]} {lappend cmd -precondition $precondition}\n" "if {[info exists postcondition]} {lappend cmd -postcondition $postcondition}\n" "eval $cmd}\n" -"::xotcl::Class method proc {name arglist body precondition:optional postcondition:optional} {\n" +"Class method proc {name arglist body precondition:optional postcondition:optional} {\n" "set cmd [list my method -per-object $name $arglist $body]\n" "if {[info exists precondition]} {lappend cmd -precondition $precondition}\n" "if {[info exists postcondition]} {lappend cmd -postcondition $postcondition}\n" "eval $cmd}\n" -"::xotcl::Class method instproc {name arglist body precondition:optional postcondition:optional} {\n" +"Class method instproc {name arglist body precondition:optional postcondition:optional} {\n" "set cmd [list my method $name $arglist $body]\n" "if {[info exists precondition]} {lappend cmd -precondition $precondition}\n" "if {[info exists postcondition]} {lappend cmd -postcondition $postcondition}\n" "eval $cmd}\n" -"::xotcl::Object create ::xotcl::@\n" -"::xotcl::@ method unknown args {}\n" -"proc ::xotcl::myproc {args} {linsert $args 0 [::xotcl::self]}\n" -"proc ::xotcl::myvar {var} {.requireNamespace; return [::xotcl::self]::$var}\n" -"namespace eval ::xotcl {\n" +"Object create ::xotcl::@\n" +"@ method unknown args {}\n" +"proc myproc {args} {linsert $args 0 [::xotcl::self]}\n" +"proc myvar {var} {.requireNamespace; return [::xotcl::self]::$var}\n" "namespace export Object Class @ myproc myvar Attribute}\n" -"::xotcl::Class create ::xotcl::MetaSlot\n" -"::xotcl::relation ::xotcl::MetaSlot superclass ::xotcl::Class\n" +"::xotcl2::Class create ::xotcl::MetaSlot\n" +"::xotcl::relation ::xotcl::MetaSlot superclass ::xotcl2::Class\n" "::xotcl::MetaSlot method new args {\n" "set slotobject [::xotcl::self callingobject]::slot\n" -"if {![::xotcl::is $slotobject object]} {::xotcl::Object create $slotobject}\n" +"if {![::xotcl::is $slotobject object]} {::xotcls::Object create $slotobject}\n" "eval next -childof $slotobject $args}\n" "::xotcl::MetaSlot create ::xotcl::Slot\n" "::xotcl::MetaSlot invalidateobjectparameter\n" "proc ::xotcl::parametersFromSlots {obj} {\n" "set parameterdefinitions [list]\n" -"set slots [::xotcl::objectInfo slotobjects $obj]\n" +"set slots [::xotcl2::objectInfo slotobjects $obj]\n" "foreach slot $slots {\n" "set parameterdefinition \"-[namespace tail $slot]\"\n" "set opts [list]\n" @@ -227,7 +227,7 @@ "return $parameterdefinitions}\n" "proc createBootstrapAttributeSlots {class definitions} {\n" "if {![::xotcl::is ${class}::slot object]} {\n" -"::xotcl::Object create ${class}::slot}\n" +"::xotcl2::Object create ${class}::slot}\n" "foreach att $definitions {\n" "if {[llength $att]>1} {foreach {att default} $att break}\n" "::xotcl::Slot create ${class}::slot::$att\n" @@ -240,7 +240,8 @@ "if {[info exists default]} {\n" "foreach i [$class info instances] {\n" "if {![$i exists $att]} {\n" -"if {[string match {*[*]*} $default]} {set default [$i eval subst $default]}\n" +"if {[string match {*[*]*} $default]} {\n" +"set default [::xotcl::dispatch $i -objscope ::eval subst $default]}\n" "::xotcl::setinstvar $i $att $default}}\n" "unset default}}\n" "$class invalidateobjectparameter}\n" @@ -273,24 +274,25 @@ "::xotcl::Slot method unknown {method args} {\n" "set methods [list]\n" "foreach m [.info methods] {\n" -"if {[::xotcl::Object info methods $m] ne \"\"} continue\n" +"if {[::xotcl2::Object info methods $m] ne \"\"} continue\n" "if {[string match __* $m]} continue\n" "lappend methods $m}\n" "error \"Method '$method' unknown for slot [::xotcl::self]; valid are: {[lsort $methods]]}\"}\n" "::xotcl::Slot method destroy {} {\n" "if {${.domain} ne \"\"} {\n" "${.domain} invalidateobjectparameter}\n" "next}\n" -"::xotcl::Slot method init {} {\n" +"::xotcl::Slot method init {args} {\n" "set forwarder [expr {${.per-object} ? \"forward\" : \"instforward\"}]\n" "if {${.domain} eq \"\"} {\n" "set .domain [::xotcl::self callingobject]} else {\n" "${.domain} invalidateobjectparameter}\n" -"${.domain} $forwarder ${.name} -default [${.manager} defaultmethods] ${.manager} %1 %self %proc}\n" +"if {${.domain} ne \"\"} {\n" +"${.domain} $forwarder ${.name} -default [${.manager} defaultmethods] ${.manager} %1 %self %proc}}\n" "::xotcl::MetaSlot create ::xotcl::InfoSlot\n" "createBootstrapAttributeSlots ::xotcl::InfoSlot {\n" "{multivalued true}\n" -"{elementtype ::xotcl::Class}}\n" +"{elementtype ::xotcl2::Class}}\n" "::xotcl::relation ::xotcl::InfoSlot superclass ::xotcl::Slot\n" "::xotcl::InfoSlot method get {obj prop} {$obj info $prop}\n" "::xotcl::InfoSlot method add {obj prop value {pos 0}} {\n" @@ -338,6 +340,7 @@ "-elementtype \"\" \\\n" "-type relation}\n" "::xotcl::MetaSlot create ::xotcl::Attribute -superclass ::xotcl::Slot\n" +"::xotcl::relation ::xotcl::Attribute superclass ::xotcl::Slot\n" "createBootstrapAttributeSlots ::xotcl::Attribute {\n" "{value_check once}\n" "initcmd\n" @@ -350,9 +353,7 @@ "::xotcl::setinstvar $obj $var [$obj eval $cmd]}\n" "::xotcl::Attribute method __value_changed_cmd {obj cmd var sub op} {\n" "eval $cmd}\n" -"::xotcl::Attribute method check_single_value {\n" -"{-keep_old_value:boolean true}\n" -"value predicate type obj var} {\n" +"::xotcl::Attribute method check_single_value { {-keep_old_value:boolean true} value predicate type obj var} {\n" "if {![expr $predicate]} {\n" "if {[$obj exists __oldvalue($var)]} {\n" "::xotcl::setinstvar $obj $var [::xotcl::setinstvar $obj __oldvalue($var)]} else {\n" @@ -390,10 +391,10 @@ "\\[list [::xotcl::self] __value_changed_cmd \\[::xotcl::self\\] [list [set .valuechangedcmd]]\\]\"}\n" "if {$__initcmd ne \"\"} {\n" "set .initcmd $__initcmd}}\n" -"::xotcl::Class create ::xotcl::Slot::Nocheck \\\n" +"::xotcl2::Class create ::xotcl::Slot::Nocheck \\\n" "-method check_single_value args {;} -method check_multiple_values args {;} \\\n" "-method mk_type_checker args {return \"\"}\n" -"::xotcl::Class create ::xotcl::Slot::Optimizer \\\n" +"::xotcl2::Class create ::xotcl::Slot::Optimizer \\\n" "-method proc args {::xotcl::next; .optimize} \\\n" "-method forward args {::xotcl::next; .optimize} \\\n" "-method init args {::xotcl::next; .optimize} \\\n" @@ -405,36 +406,38 @@ "set forwarder [expr {[set .per-object] ? \"parametercmd\":\"instparametercmd\"}]\n" "${.domain} $forwarder ${.name}}\n" "::xotcl::Attribute instmixin add ::xotcl::Slot::Optimizer\n" -"::xotcl::Class create ::xotcl::ScopedNew -superclass ::xotcl::Class\n" +"::xotcl2::Class create ::xotcl::ScopedNew -superclass ::xotcl2::Class\n" "createBootstrapAttributeSlots ::xotcl::ScopedNew {\n" -"{withclass ::xotcl::Object}\n" +"{withclass ::xotcl2::Object}\n" "inobject}\n" "::xotcl::ScopedNew method init {} {\n" ".method new {-childof args} {\n" "[::xotcl::self class] instvar {inobject object} withclass\n" "if {![::xotcl::is $object object]} {\n" "$withclass create $object}\n" "eval ::xotcl::next -childof $object $args}}\n" -"::xotcl::Object method contains {\n" +"::xotcl2::Object method contains {\n" "{-withnew:boolean true}\n" "-object\n" -"{-class ::xotcl::Object}\n" +"{-class ::xotcl2::Object}\n" "cmds} {\n" "if {![info exists object]} {set object [::xotcl::self]}\n" "if {![::xotcl::is $object object]} {$class create $object}\n" "$object requireNamespace\n" "if {$withnew} {\n" "set m [::xotcl::ScopedNew new \\\n" "-inobject $object -withclass $class -volatile]\n" -"::xotcl::Class instmixin add $m end\n" +"::xotcl2::Class instmixin add $m end\n" "namespace eval $object $cmds\n" -"::xotcl::Class instmixin delete $m} else {\n" +"::xotcl2::Class instmixin delete $m} else {\n" "namespace eval $object $cmds}}\n" +"::xotcl2::Class instforward slots %self contains \\\n" +"-object {%::xotcl::dispatch [::xotcl::self] -objscope ::subst [::xotcl::self]::slot}\n" "::xotcl::Class instforward slots %self contains \\\n" "-object {%::xotcl::dispatch [::xotcl::self] -objscope ::subst [::xotcl::self]::slot}\n" -"::xotcl::Class method parameter arglist {\n" +"::xotcl2::Class method parameter arglist {\n" "if {![::xotcl::is [::xotcl::self]::slot object]} {\n" -"::xotcl::Object create [::xotcl::self]::slot}\n" +"::xotcl2::Object create [::xotcl::self]::slot}\n" "foreach arg $arglist {\n" "set l [llength $arg]\n" "set name [lindex $arg 0]\n" @@ -461,7 +464,7 @@ "lappend cmd -default $paramstring\n" "eval $cmd\n" "continue}\n" -"set po ::xotcl::Class::Parameter\n" +"set po ::xotcl2::Class::Parameter\n" "puts stderr \"deprecated parameter usage '$arg'; use '-slots {Attribute ...}' instead\"\n" "set cl [::xotcl::self]\n" "::xotcl::setinstvar $po name $name\n" @@ -491,7 +494,8 @@ "::xotcl::is [self] type $cl}\n" "::xotcl::Class method allinstances {} {\n" "return [.info instances -closure]}\n" -"::xotcl::alias ::xotcl2::Class parameter ::xotcl::classes::xotcl::Class::parameter\n" +"::xotcl::alias ::xotcl::Class parameter ::xotcl::classes::xotcl2::Class::parameter\n" +"::xotcl::alias ::xotcl::Object contains ::xotcl::classes::xotcl2::Object::contains\n" "::xotcl::alias ::xotcl2::Object defaultmethod ::xotcl::classes::xotcl::Object::defaultmethod\n" "::xotcl::Object method -per-object unsetExitHandler {} {\n" "::xotcl::Object method -per-object __exitHandler {} {\n" @@ -511,7 +515,7 @@ "if {!\\[::xotcl::self isnextcall\\]} {\n" "error \\\"Abstract method $methname $arglist called\\\"} else {::xotcl::next}\n" "\"}\n" -"::xotcl::Class create ::xotcl::Object::CopyHandler -parameter {\n" +"::xotcl2::Class create ::xotcl::Object::CopyHandler -parameter {\n" "{targetList \"\"}\n" "{dest \"\"}\n" "objLength}\n" @@ -560,7 +564,7 @@ "eval [concat $dest instforward $i [$origin info instforward -definition $i]]}}\n" "set traces [list]\n" "foreach var [$origin info vars] {\n" -"set cmds [$origin trace info variable $var]\n" +"set cmds [::xotcl::dispatch $origin -objscope ::trace info variable $var]\n" "if {$cmds ne \"\"} {\n" "foreach cmd $cmds {\n" "foreach {op def} $cmd break\n" Index: generic/predefined.xotcl =================================================================== diff -u -rfad871fc9a27570119d6bf9dbed84b7469701bd6 -rc11ab22190bdfe6231b454e9969b6ffafb547f9c --- generic/predefined.xotcl (.../predefined.xotcl) (revision fad871fc9a27570119d6bf9dbed84b7469701bd6) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision c11ab22190bdfe6231b454e9969b6ffafb547f9c) @@ -1,4 +1,12 @@ -# first we create the ::xotcl2 object system. +# +# By setting the variable bootstrap, we can check later, whether we +# are in bootstrapping mode +# +set bootstrap 1 + +# +# First create the ::xotcl2 object system. +# namespace eval xotcl2 { namespace path ::xotcl ::xotcl::createobjectsystem ::xotcl2::Object ::xotcl2::Class @@ -43,41 +51,35 @@ # # create class and object for nonpositional argument processing - Class create ParameterType + Class create ::xotcl2::ParameterType foreach cmd [info command ::xotcl::cmd::ParameterType::*] { - ::xotcl::alias ParameterType [namespace tail $cmd] $cmd + ::xotcl::alias ::xotcl2::ParameterType [namespace tail $cmd] $cmd } # create an object for dispatching - ParameterType create parameterType + ::xotcl2::ParameterType create ::xotcl2::parameterType ######################## # Info definition ######################## - Object create objectInfo - Object create classInfo + Object create ::xotcl2::objectInfo + Object create ::xotcl2::classInfo - #foreach o {objectInfo classInfo} { - # foreach r {object class metaclass} { - # puts stderr "$o $r=[::xotcl::is $o $r]" - # } - #} - foreach cmd [info command ::xotcl::cmd::ObjectInfo::*] { - ::xotcl::alias objectInfo [namespace tail $cmd] $cmd - ::xotcl::alias classInfo [namespace tail $cmd] $cmd + ::xotcl::alias ::xotcl2::objectInfo [namespace tail $cmd] $cmd + ::xotcl::alias ::xotcl2::classInfo [namespace tail $cmd] $cmd } foreach cmd [info command ::xotcl::cmd::ClassInfo::*] { - ::xotcl::alias classInfo [namespace tail $cmd] $cmd + ::xotcl::alias ::xotcl2::classInfo [namespace tail $cmd] $cmd } unset cmd - ::xotcl::alias objectInfo is ::xotcl::is - ::xotcl::alias classInfo is ::xotcl::is - ::xotcl::alias classInfo classparent ::xotcl::cmd::ObjectInfo::parent - ::xotcl::alias classInfo classchildren ::xotcl::cmd::ObjectInfo::children + ::xotcl::alias ::xotcl2::objectInfo is ::xotcl::is + ::xotcl::alias ::xotcl2::classInfo is ::xotcl::is + ::xotcl::alias ::xotcl2::classInfo classparent ::xotcl::cmd::ObjectInfo::parent + ::xotcl::alias ::xotcl2::classInfo classchildren ::xotcl::cmd::ObjectInfo::children - Object instforward info -onerror ::xotcl::infoError ::xotcl::objectInfo %1 {%@2 %self} - Class instforward info -onerror ::xotcl::infoError ::xotcl::classInfo %1 {%@2 %self} + Object instforward info -onerror ::xotcl::infoError ::xotcl2::objectInfo %1 {%@2 %self} + Class instforward info -onerror ::xotcl::infoError ::xotcl2::classInfo %1 {%@2 %self} proc ::xotcl::infoError msg { #puts stderr "INFO ERROR: <$msg>\n$::errorInfo" @@ -118,300 +120,266 @@ namespace eval ::xotcl { # - # Perform the basic setup of XOTcl. First, let us allocate the + # Perform the basic setup of XOTcl 1.x. First, let us allocate the # basic classes of XOTcl. This call creates the classes - # ::xotcl::Object and ::xotcl::Class and defines these as root - # class of the object system and as root meta class. + # ::xotcl::Object and ::xotcl::Class and defines these as root class + # of the object system and as root meta class. # ::xotcl::createobjectsystem ::xotcl::Object ::xotcl::Class - # foreach o {::xotcl::Object ::xotcl::Class} { - # foreach r {object class metaclass} { - # puts stderr "$o $r=[::xotcl::is $o $r]" - # } - # } + # provide the standard command set for ::xotcl::Object + foreach cmd [info command ::xotcl::cmd::Object::*] { + ::xotcl::alias Object [namespace tail $cmd] $cmd + } - # - # createobjectsystem creates already the relation that Class has Object as - # superclass. We could define this here as well. - # - # puts stderr sc(class)=[::xotcl::relation ::xotcl::Class superclass] - # ::xotcl::relation ::xotcl::Class superclass ::xotcl::Object + # provide some Tcl-commands as methods for ::xotcl::Object + foreach cmd {array append eval incr lappend set subst unset trace} { + ::xotcl::alias Object $cmd -objscope ::$cmd + } + + # provide the standard command set for ::xotcl::Class + foreach cmd [info command ::xotcl::cmd::Class::*] { + ::xotcl::alias Class [namespace tail $cmd] $cmd + } + unset cmd - # - # createobjectsystem creates already the relation that Object and - # Class are instances of Class. We could define this here as well. - # - # puts stderr cl(object)=[::xotcl::relation ::xotcl::Object class] - # puts stderr cl(class)=[::xotcl::relation ::xotcl::Class class] - # ::xotcl::relation ::xotcl::Object class ::xotcl::Class - # ::xotcl::relation ::xotcl::Class class ::xotcl::Class -} + # protect some methods against redefinition + ::xotcl::methodproperty Object destroy static true + ::xotcl::methodproperty Class alloc static true + ::xotcl::methodproperty Class dealloc static true + ::xotcl::methodproperty Class create static true -# -# By setting the variable bootstrap, we can check later, whether we -# are in bootstrapping mode -# -set bootstrap 1 + Class method unknown {args} { + #puts stderr "use '[self] create $args', not '[self] $args'" + eval my create $args + } -# provide the standard command set for ::xotcl::Object -foreach cmd [info command ::xotcl::cmd::Object::*] { - ::xotcl::alias ::xotcl::Object [namespace tail $cmd] $cmd -} + Object method unknown {m args} { + if {![self isnext]} { + error "[self]: unable to dispatch method '$m'" + } + } -# provide some Tcl-commands as methods for ::xotcl::Object -foreach cmd {array append eval incr lappend set subst unset trace} { - ::xotcl::alias ::xotcl::Object $cmd -objscope ::$cmd -} + # "init" must exist on Object. per default it is empty. + Object method init args {} -# provide the standard command set for ::xotcl::Class -foreach cmd [info command ::xotcl::cmd::Class::*] { - ::xotcl::alias ::xotcl::Class [namespace tail $cmd] $cmd -} + # provide a placeholder for the bootup process. The real definition + # is based on slots, which are not available at this point. + Object method objectparameter {} {;} -# protect some methods against redefinition -::xotcl::methodproperty ::xotcl::Object destroy static true -::xotcl::methodproperty ::xotcl::Class alloc static true -::xotcl::methodproperty ::xotcl::Class dealloc static true -::xotcl::methodproperty ::xotcl::Class create static true + # + # create class and object for nonpositional argument processing + Class create ::xotcl::ParameterType + foreach cmd [info command ::xotcl::cmd::ParameterType::*] { + ::xotcl::alias ::xotcl::ParameterType [namespace tail $cmd] $cmd + } + # register type boolean as checker for "switch" + ::xotcl::alias ::xotcl::ParameterType type=switch ::xotcl::cmd::ParameterType::type=boolean + # create an object for dispatching + ::xotcl::ParameterType create ::xotcl::parameterType -::xotcl::Class method unknown {args} { - #puts stderr "use '[self] create $args', not '[self] $args'" - eval my create $args -} + ######################## + # Info definition + ######################## + Object create ::xotcl::objectInfo + Object create ::xotcl::classInfo -::xotcl::Object method unknown {m args} { - if {![self isnext]} { - error "[self]: unable to dispatch method '$m'" + foreach cmd [info command ::xotcl::cmd::ObjectInfo::*] { + ::xotcl::alias ::xotcl::objectInfo [namespace tail $cmd] $cmd + ::xotcl::alias ::xotcl::classInfo [namespace tail $cmd] $cmd } -} + foreach cmd [info command ::xotcl::cmd::ClassInfo::*] { + ::xotcl::alias ::xotcl::classInfo [namespace tail $cmd] $cmd + } + unset cmd + ::xotcl::alias ::xotcl::objectInfo is ::xotcl::is + ::xotcl::alias ::xotcl::classInfo is ::xotcl::is + ::xotcl::alias ::xotcl::classInfo classparent ::xotcl::cmd::ObjectInfo::parent + ::xotcl::alias ::xotcl::classInfo classchildren ::xotcl::cmd::ObjectInfo::children -# "init" must exist on Object. per default it is empty. -::xotcl::Object method init args {} + Object instforward info -onerror ::xotcl::infoError ::xotcl::objectInfo %1 {%@2 %self} + Class instforward info -onerror ::xotcl::infoError ::xotcl::classInfo %1 {%@2 %self} -# provide a placeholder for the bootup process. The real definition -# is based on slots, which are not available at this point. -::xotcl::Object method objectparameter {} {;} - -# -# create class and object for nonpositional argument processing -::xotcl::Class create ::xotcl::ParameterType -foreach cmd [info command ::xotcl::cmd::ParameterType::*] { - ::xotcl::alias ::xotcl::ParameterType [namespace tail $cmd] $cmd -} -# register type boolean as checker for "switch" -::xotcl::alias ::xotcl::ParameterType type=switch ::xotcl::cmd::ParameterType::type=boolean -# create an object for dispatching -::xotcl::ParameterType create ::xotcl::parameterType - -######################## -# Info definition -######################## -::xotcl::Object create ::xotcl::objectInfo -::xotcl::Object create ::xotcl::classInfo - -#foreach o {::xotcl::objectInfo ::xotcl::classInfo} { -# foreach r {object class metaclass} { -# puts stderr "$o $r=[::xotcl::is $o $r]" -# } -#} - -foreach cmd [info command ::xotcl::cmd::ObjectInfo::*] { - ::xotcl::alias ::xotcl::objectInfo [namespace tail $cmd] $cmd - ::xotcl::alias ::xotcl::classInfo [namespace tail $cmd] $cmd -} -foreach cmd [info command ::xotcl::cmd::ClassInfo::*] { - ::xotcl::alias ::xotcl::classInfo [namespace tail $cmd] $cmd -} -unset cmd -::xotcl::alias ::xotcl::objectInfo is ::xotcl::is -::xotcl::alias ::xotcl::classInfo is ::xotcl::is -::xotcl::alias ::xotcl::classInfo classparent ::xotcl::cmd::ObjectInfo::parent -::xotcl::alias ::xotcl::classInfo classchildren ::xotcl::cmd::ObjectInfo::children - -::xotcl::Object instforward info -onerror ::xotcl::infoError ::xotcl::objectInfo %1 {%@2 %self} -::xotcl::Class instforward info -onerror ::xotcl::infoError ::xotcl::classInfo %1 {%@2 %self} - -proc ::xotcl::infoError msg { - #puts stderr "INFO ERROR: <$msg>\n$::errorInfo" - regsub -all " " $msg "" msg - regsub -all " " $msg "" msg - regsub {\"} $msg "\"info " msg - error $msg "" -} -::xotcl::objectInfo method info {obj} { - set methods [list] - foreach m [::info commands ::xotcl::objectInfo::*] { - set name [namespace tail $m] - if {$name eq "unknown"} continue - lappend methods $name + # TODO: the following method is defined redundantly + proc ::xotcl::infoError msg { + #puts stderr "INFO ERROR: <$msg>\n$::errorInfo" + regsub -all " " $msg "" msg + regsub -all " " $msg "" msg + regsub {\"} $msg "\"info " msg + error $msg "" } - return "valid options are: [join [lsort $methods] {, }]" -} -::xotcl::objectInfo method unknown {method args} { - error "unknown info option \"$method\"; [.info info]" -} - -::xotcl::classInfo method info {cl} { - set methods [list] - foreach m [::info commands ::xotcl::classInfo::*] { - set name [namespace tail $m] - if {$name eq "unknown"} continue - lappend methods $name + objectInfo method info {obj} { + set methods [list] + foreach m [::info commands ::xotcl::objectInfo::*] { + set name [namespace tail $m] + if {$name eq "unknown"} continue + lappend methods $name + } + return "valid options are: [join [lsort $methods] {, }]" } - return "valid options are: [join [lsort $methods] {, }]" -} -::xotcl::classInfo method unknown {method args} { - error "unknown info option \"$method\"; [.info info]" -} + objectInfo method unknown {method args} { + error "unknown info option \"$method\"; [.info info]" + } + + classInfo method info {cl} { + set methods [list] + foreach m [::info commands ::xotcl::classInfo::*] { + set name [namespace tail $m] + if {$name eq "unknown"} continue + lappend methods $name + } + return "valid options are: [join [lsort $methods] {, }]" + } + classInfo method unknown {method args} { + error "unknown info option \"$method\"; [.info info]" + } -# -# Backward compatibility info subcommands; -# -# TODO: should go finally into a library. -# -# Obsolete methods -# -# already emulated: -# -# => info params .... replaces -# info args -# info nonposargs -# info default -# -# => info instparams .... replaces -# info instargs -# info instnonposargs -# info instdefault -# -# => maybe instead of "info params" and "info instparams" -# info params ?-per-object? -# -# => TODO: use "params" in serializer, and all other occurances -# -# TODO: not yet emulated: -# -# => info is (bzw. ::xotcl::is) replaces -# isobject -# isclass -# ismetaclass -# ismixin -# istype -# -# => method (should get pre- and postconditions via positional params) -# proc -# instproc -# -# TODO mark all absolete calls at least as deprecated in library -# -# TODO move unknown handler for Class into a library, make sure that -# regression test and library function use explicit "creates". -# + # + # Backward compatibility info subcommands; + # + # TODO: should go finally into a library. + # + # Obsolete methods + # + # already emulated: + # + # => info params .... replaces + # info args + # info nonposargs + # info default + # + # => info instparams .... replaces + # info instargs + # info instnonposargs + # info instdefault + # + # => maybe instead of "info params" and "info instparams" + # info params ?-per-object? + # + # => TODO: use "params" in serializer, and all other occurances + # + # TODO: not yet emulated: + # + # => info is (bzw. ::xotcl::is) replaces + # isobject + # isclass + # ismetaclass + # ismixin + # istype + # + # => method (should get pre- and postconditions via positional params) + # proc + # instproc + # + # TODO mark all absolete calls at least as deprecated in library + # + # TODO move unknown handler for Class into a library, make sure that + # regression test and library function use explicit "creates". + # -proc ::xotcl::info_args {inst o method} { + proc ::xotcl::info_args {inst o method} { set result [list] foreach \ argName [::xotcl::classInfo ${inst}params $o $method -varNames] \ flag [::xotcl::classInfo ${inst}params $o $method] { if {[string match -* $flag]} continue lappend result $argName } - #puts stderr "+++ get ${inst}args for $o $method => $result" - return $result -} -proc ::xotcl::info_nonposargs {inst o method} { - set result [list] - foreach flag [::xotcl::classInfo ${inst}params $o $method] { - if {![string match -* $flag]} continue - lappend result $flag + #puts stderr "+++ get ${inst}args for $o $method => $result" + return $result } - #puts stderr "+++ get ${inst}nonposargs for $o $method => $result" - return $result -} -proc ::xotcl::info_default {inst o method arg varName} { - foreach \ - argName [::xotcl::classInfo ${inst}params $o $method -varNames] \ - flag [::xotcl::classInfo ${inst}params $o $method] { - if {$argName eq $arg} { - upvar 3 $varName default - if {[llength $flag] == 2} { - set default [lindex $flag 1] - #puts stderr "--- get ${inst}default for $o $method $arg => $default" - return 1 - } - #puts stderr "--- get ${inst}default for $o $method $arg fails" - set default "" - return 0 - } - } - error "procedure \"$method\" doesn't have an argument \"$varName\"" -} -::xotcl::classInfo method instargs {o method} {::xotcl::info_args inst $o $method} -::xotcl::classInfo method args {o method} {::xotcl::info_args "" $o $method} -::xotcl::objectInfo method args {o method} {::xotcl::info_args "" $o $method} + proc ::xotcl::info_nonposargs {inst o method} { + set result [list] + foreach flag [::xotcl::classInfo ${inst}params $o $method] { + if {![string match -* $flag]} continue + lappend result $flag + } + #puts stderr "+++ get ${inst}nonposargs for $o $method => $result" + return $result + } + proc ::xotcl::info_default {inst o method arg varName} { + foreach \ + argName [::xotcl::classInfo ${inst}params $o $method -varNames] \ + flag [::xotcl::classInfo ${inst}params $o $method] { + if {$argName eq $arg} { + upvar 3 $varName default + if {[llength $flag] == 2} { + set default [lindex $flag 1] + #puts stderr "--- get ${inst}default for $o $method $arg => $default" + return 1 + } + #puts stderr "--- get ${inst}default for $o $method $arg fails" + set default "" + return 0 + } + } + error "procedure \"$method\" doesn't have an argument \"$varName\"" + } + + classInfo method instargs {o method} {::xotcl::info_args inst $o $method} + classInfo method args {o method} {::xotcl::info_args "" $o $method} + objectInfo method args {o method} {::xotcl::info_args "" $o $method} + + classInfo method instnonposargs {o method} {::xotcl::info_nonposargs inst $o $method} + classInfo method nonposargs {o method} {::xotcl::info_nonposargs "" $o $method} + objectInfo method nonposargs {o method} {::xotcl::info_nonposargs "" $o $method} + + classInfo method instdefault {o method arg var} {::xotcl::info_default inst $o $method $arg $var} + classInfo method default {o method arg var} {::xotcl::info_default "" $o $method $arg $var} + objectInfo method default {o method arg var} {::xotcl::info_default "" $o $method $arg $var} -::xotcl::classInfo method instnonposargs {o method} {::xotcl::info_nonposargs inst $o $method} -::xotcl::classInfo method nonposargs {o method} {::xotcl::info_nonposargs "" $o $method} -::xotcl::objectInfo method nonposargs {o method} {::xotcl::info_nonposargs "" $o $method} + # emulation of isobject, ... + Object method isobject {{object:substdefault "[self]"}} {::xotcl::is $object object} + Object method isclass {{class:substdefault "[self]"}} {::xotcl::is $class class} + Object method ismetaclass {{class:substdefault "[self]"}} {::xotcl::is $class metaclass} + Object method ismixin {class} {::xotcl::is [self] mixin $class} + Object method istype {class} {::xotcl::is [self] type $class} -::xotcl::classInfo method instdefault {o method arg var} {::xotcl::info_default inst $o $method $arg $var} -::xotcl::classInfo method default {o method arg var} {::xotcl::info_default "" $o $method $arg $var} -::xotcl::objectInfo method default {o method arg var} {::xotcl::info_default "" $o $method $arg $var} + # + Object method proc {name arglist body precondition:optional postcondition:optional} { + set cmd [list my method $name $arglist $body] + if {[info exists precondition]} {lappend cmd -precondition $precondition} + if {[info exists postcondition]} {lappend cmd -postcondition $postcondition} + eval $cmd + } + Class method proc {name arglist body precondition:optional postcondition:optional} { + set cmd [list my method -per-object $name $arglist $body] + if {[info exists precondition]} {lappend cmd -precondition $precondition} + if {[info exists postcondition]} {lappend cmd -postcondition $postcondition} + eval $cmd + } + Class method instproc {name arglist body precondition:optional postcondition:optional} { + set cmd [list my method $name $arglist $body] + if {[info exists precondition]} {lappend cmd -precondition $precondition} + if {[info exists postcondition]} {lappend cmd -postcondition $postcondition} + eval $cmd + } -# emulation of isobject, ... -::xotcl::Object method isobject {{object:substdefault "[self]"}} {::xotcl::is $object object} -::xotcl::Object method isclass {{class:substdefault "[self]"}} {::xotcl::is $class class} -::xotcl::Object method ismetaclass {{class:substdefault "[self]"}} {::xotcl::is $class metaclass} -::xotcl::Object method ismixin {class} {::xotcl::is [self] mixin $class} -::xotcl::Object method istype {class} {::xotcl::is [self] type $class} + # documentation stub object -> just ignore per default. + # if xoDoc is loaded, documentation will be activated + Object create ::xotcl::@ + @ method unknown args {} -# -::xotcl::Object method proc {name arglist body precondition:optional postcondition:optional} { - set cmd [list my method $name $arglist $body] - if {[info exists precondition]} {lappend cmd -precondition $precondition} - if {[info exists postcondition]} {lappend cmd -postcondition $postcondition} - eval $cmd -} -::xotcl::Class method proc {name arglist body precondition:optional postcondition:optional} { - set cmd [list my method -per-object $name $arglist $body] - if {[info exists precondition]} {lappend cmd -precondition $precondition} - if {[info exists postcondition]} {lappend cmd -postcondition $postcondition} - eval $cmd -} -::xotcl::Class method instproc {name arglist body precondition:optional postcondition:optional} { - set cmd [list my method $name $arglist $body] - if {[info exists precondition]} {lappend cmd -precondition $precondition} - if {[info exists postcondition]} {lappend cmd -postcondition $postcondition} - eval $cmd -} - -# documentation stub object -> just ignore per default. -# if xoDoc is loaded, documentation will be activated -::xotcl::Object create ::xotcl::@ -::xotcl::@ method unknown args {} - -proc ::xotcl::myproc {args} {linsert $args 0 [::xotcl::self]} -proc ::xotcl::myvar {var} {.requireNamespace; return [::xotcl::self]::$var} - -namespace eval ::xotcl { + proc myproc {args} {linsert $args 0 [::xotcl::self]} + proc myvar {var} {.requireNamespace; return [::xotcl::self]::$var} + namespace export Object Class @ myproc myvar Attribute } - ################## # Slot definitions ################## # # TODO: define base slots on xotcl2::Object + Class instead of ::xotcl::Object # # still bootstrap code; we cannot use slots/-parameter yet -::xotcl::Class create ::xotcl::MetaSlot -::xotcl::relation ::xotcl::MetaSlot superclass ::xotcl::Class +::xotcl2::Class create ::xotcl::MetaSlot +::xotcl::relation ::xotcl::MetaSlot superclass ::xotcl2::Class ::xotcl::MetaSlot method new args { set slotobject [::xotcl::self callingobject]::slot - if {![::xotcl::is $slotobject object]} {::xotcl::Object create $slotobject} + if {![::xotcl::is $slotobject object]} {::xotcls::Object create $slotobject} eval next -childof $slotobject $args } @@ -421,7 +389,7 @@ # avoid caching. ::xotcl::MetaSlot invalidateobjectparameter -#foreach o {::xotcl::MetaSlot ::xotcl::Slot} { +#foreach o {::xotcl::MetaSlot ::xotcl2::Slot} { # foreach r {object class metaclass} { # puts stderr "$o $r=[::xotcl::is $o $r]" # } @@ -432,7 +400,7 @@ proc ::xotcl::parametersFromSlots {obj} { #puts stderr "XXXX-objectparameter for $obj" set parameterdefinitions [list] - set slots [::xotcl::objectInfo slotobjects $obj] + set slots [::xotcl2::objectInfo slotobjects $obj] foreach slot $slots { set parameterdefinition "-[namespace tail $slot]" set opts [list] @@ -473,8 +441,10 @@ } ::xotcl2::Object method objectparameter {} { set parameterdefinitions [::xotcl::parametersFromSlots [self]] - # TODO: do we want to use "Class C -parameter {...}" or "Class C {.parameter {...}}" - #lappend parameterdefinitions arg:optional,initcmd + #if {[::xotcl::is [self] class]} { + # lappend parameterdefinitions -parameter:method,optional + #} + #lappend parameterdefinitions arg:initcmd,optional # for the time being, use: lappend parameterdefinitions args #puts stderr "*** parameter definition for [self]: $parameterdefinitions" @@ -487,7 +457,7 @@ proc createBootstrapAttributeSlots {class definitions} { if {![::xotcl::is ${class}::slot object]} { - ::xotcl::Object create ${class}::slot + ::xotcl2::Object create ${class}::slot } foreach att $definitions { if {[llength $att]>1} {foreach {att default} $att break} @@ -507,7 +477,10 @@ # checking subclasses is not required during bootstrap foreach i [$class info instances] { if {![$i exists $att]} { - if {[string match {*[*]*} $default]} {set default [$i eval subst $default]} + if {[string match {*[*]*} $default]} { + #set default [$i eval subst $default] + set default [::xotcl::dispatch $i -objscope ::eval subst $default] + } ::xotcl::setinstvar $i $att $default } } @@ -518,6 +491,14 @@ $class invalidateobjectparameter } + +# +# TODO: +# - are createBootstrapAttributeSlots for ::xotcl::Class still needed? +# - Defaults for objectparameter seem more natural. +# - no definition yet for xotcl2::Class +# + # We provide a default value for superclass (when no superclass is specified explicitely) # for defining the top-level class of the object system, such that different # object systems might co-exist. @@ -571,7 +552,7 @@ ::xotcl::Slot method unknown {method args} { set methods [list] foreach m [.info methods] { - if {[::xotcl::Object info methods $m] ne ""} continue + if {[::xotcl2::Object info methods $m] ne ""} continue if {[string match __* $m]} continue lappend methods $m } @@ -585,17 +566,17 @@ next } -::xotcl::Slot method init {} { +::xotcl::Slot method init {args} { + #puts stderr init-got-'$args' set forwarder [expr {${.per-object} ? "forward" : "instforward"}] if {${.domain} eq ""} { set .domain [::xotcl::self callingobject] } else { - #todo could be done via slotoptimizer - #puts stderr "Slot [self] (name ${.name}) init ${.domain} calls invalidateobjectparameter" ${.domain} invalidateobjectparameter } - #puts stderr "???? ${.domain} $forwarder ${.name} -default [${.manager} defaultmethods] ${.manager} %1 %self %proc" - ${.domain} $forwarder ${.name} -default [${.manager} defaultmethods] ${.manager} %1 %self %proc + if {${.domain} ne ""} { + ${.domain} $forwarder ${.name} -default [${.manager} defaultmethods] ${.manager} %1 %self %proc + } } # @@ -604,7 +585,7 @@ ::xotcl::MetaSlot create ::xotcl::InfoSlot createBootstrapAttributeSlots ::xotcl::InfoSlot { {multivalued true} - {elementtype ::xotcl::Class} + {elementtype ::xotcl2::Class} } ::xotcl::relation ::xotcl::InfoSlot superclass ::xotcl::Slot ::xotcl::InfoSlot method get {obj prop} {$obj info $prop} @@ -661,6 +642,7 @@ ###################### # system slots ###################### +# register the system slots on both, xotcl and xotcl2 foreach os {::xotcl ::xotcl2} { ${os}::Object alloc ${os}::Class::slot ${os}::Object alloc ${os}::Object::slot @@ -682,9 +664,13 @@ } # +# # Attribute # +# TODO: why does -superclass not work here? +# before, the subsequent ::xotcl::relation was not needed. ::xotcl::MetaSlot create ::xotcl::Attribute -superclass ::xotcl::Slot +::xotcl::relation ::xotcl::Attribute superclass ::xotcl::Slot createBootstrapAttributeSlots ::xotcl::Attribute { {value_check once} @@ -707,10 +693,7 @@ # puts "valuechanged obj=$obj cmd=$cmd, var=$var, op=$op, ...\n$obj exists $var -> [::xotcl::setinstvar $obj $var]" eval $cmd } -::xotcl::Attribute method check_single_value { - {-keep_old_value:boolean true} - value predicate type obj var - } { +::xotcl::Attribute method check_single_value { {-keep_old_value:boolean true} value predicate type obj var} { #puts "+++ checking single value '$value' with $predicate ==> [expr $predicate]" if {![expr $predicate]} { if {[$obj exists __oldvalue($var)]} { @@ -778,10 +761,11 @@ } # mixin class for decativating all checks -::xotcl::Class create ::xotcl::Slot::Nocheck \ +::xotcl2::Class create ::xotcl::Slot::Nocheck \ -method check_single_value args {;} -method check_multiple_values args {;} \ -method mk_type_checker args {return ""} -::xotcl::Class create ::xotcl::Slot::Optimizer \ +# mixin class for optimizing slots +::xotcl2::Class create ::xotcl::Slot::Optimizer \ -method proc args {::xotcl::next; .optimize} \ -method forward args {::xotcl::next; .optimize} \ -method init args {::xotcl::next; .optimize} \ @@ -804,9 +788,9 @@ # new objects in ::xotcl::*, but in the specified object (without # syntactic overhead). # -::xotcl::Class create ::xotcl::ScopedNew -superclass ::xotcl::Class +::xotcl2::Class create ::xotcl::ScopedNew -superclass ::xotcl2::Class createBootstrapAttributeSlots ::xotcl::ScopedNew { - {withclass ::xotcl::Object} + {withclass ::xotcl2::Object} inobject } @@ -825,33 +809,35 @@ # nested object structures. Optionally, creating new objects # in the specified scope can be turned off. # -::xotcl::Object method contains { - {-withnew:boolean true} - -object - {-class ::xotcl::Object} - cmds} { +::xotcl2::Object method contains { + {-withnew:boolean true} + -object + {-class ::xotcl2::Object} + cmds + } { if {![info exists object]} {set object [::xotcl::self]} if {![::xotcl::is $object object]} {$class create $object} $object requireNamespace if {$withnew} { set m [::xotcl::ScopedNew new \ -inobject $object -withclass $class -volatile] - ::xotcl::Class instmixin add $m end + ::xotcl2::Class instmixin add $m end namespace eval $object $cmds - ::xotcl::Class instmixin delete $m + ::xotcl2::Class instmixin delete $m } else { namespace eval $object $cmds } } +::xotcl2::Class instforward slots %self contains \ + -object {%::xotcl::dispatch [::xotcl::self] -objscope ::subst [::xotcl::self]::slot} ::xotcl::Class instforward slots %self contains \ -object {%::xotcl::dispatch [::xotcl::self] -objscope ::subst [::xotcl::self]::slot} - # # define parameter for backward compatibility and convenience # -::xotcl::Class method parameter arglist { +::xotcl2::Class method parameter arglist { if {![::xotcl::is [::xotcl::self]::slot object]} { - ::xotcl::Object create [::xotcl::self]::slot + ::xotcl2::Object create [::xotcl::self]::slot } foreach arg $arglist { set l [llength $arg] @@ -878,7 +864,6 @@ #puts stderr "parameter $arg without default -> $cmd" } elseif {$l == 2} { lappend cmd -default [lindex $arg 1] - #puts stderr "parameter $arg with default -> $cmd" eval $cmd } elseif {$l == 3 && [lindex $arg 1] eq "-default"} { lappend cmd -default [lindex $arg 2] @@ -891,7 +876,7 @@ continue } - set po ::xotcl::Class::Parameter + set po ::xotcl2::Class::Parameter puts stderr "deprecated parameter usage '$arg'; use '-slots {Attribute ...}' instead" set cl [::xotcl::self] @@ -944,12 +929,17 @@ # reuse definitions from xotcl in xotcl2 # TODO: can this be done with interp aliases? -::xotcl::alias ::xotcl2::Class parameter ::xotcl::classes::xotcl::Class::parameter +::xotcl::alias ::xotcl::Class parameter ::xotcl::classes::xotcl2::Class::parameter +::xotcl::alias ::xotcl::Object contains ::xotcl::classes::xotcl2::Object::contains ::xotcl::alias ::xotcl2::Object defaultmethod ::xotcl::classes::xotcl::Object::defaultmethod #interp alias {} ::xotcl::classes::xotcl::Class::parameter {} ::xotcl::classes::xotcl2::Class::parameter #interp alias {} ::xotcl::classes::xotcl::Object::defaultmethod {} ::xotcl::classes::xotcl2::Object::defaultmethod +# +# TODO remainder should move from ::xotcl::Object -> xotcl2::* +# + # Exit Handler ::xotcl::Object method -per-object unsetExitHandler {} { ::xotcl::Object method -per-object __exitHandler {} { @@ -984,7 +974,7 @@ # # copy/move implementation # -::xotcl::Class create ::xotcl::Object::CopyHandler -parameter { +::xotcl2::Class create ::xotcl::Object::CopyHandler -parameter { {targetList ""} {dest ""} objLength @@ -1070,7 +1060,7 @@ } set traces [list] foreach var [$origin info vars] { - set cmds [$origin trace info variable $var] + set cmds [::xotcl::dispatch $origin -objscope ::trace info variable $var] if {$cmds ne ""} { foreach cmd $cmds { foreach {op def} $cmd break Index: tests/speedtest.xotcl =================================================================== diff -u -r98003953e8c728b105528e0c2ed7d67ee7135d64 -rc11ab22190bdfe6231b454e9969b6ffafb547f9c --- tests/speedtest.xotcl (.../speedtest.xotcl) (revision 98003953e8c728b105528e0c2ed7d67ee7135d64) +++ tests/speedtest.xotcl (.../speedtest.xotcl) (revision c11ab22190bdfe6231b454e9969b6ffafb547f9c) @@ -15,6 +15,7 @@ set ocount 1014 set ocount [expr {$ccount + 206}] set ocount [expr {$ccount + 15}] +set ocount [expr {$ccount + 7}] set startObjects [Object info instances] set x [llength [Object info instances]] Index: tests/testx.xotcl =================================================================== diff -u -r675e28583d105313f7fbc1dad66d2696c18b19f4 -rc11ab22190bdfe6231b454e9969b6ffafb547f9c --- tests/testx.xotcl (.../testx.xotcl) (revision 675e28583d105313f7fbc1dad66d2696c18b19f4) +++ tests/testx.xotcl (.../testx.xotcl) (revision c11ab22190bdfe6231b454e9969b6ffafb547f9c) @@ -2025,11 +2025,11 @@ Object instfilter "" ::errorCheck $::calling \ - "{filter f: ::mixinTest {} run draw {::MenuDecorator instproc draw}} {m1 draw: ::mixinTest {} run {::ScrollBarDecorator instproc draw}} {m2 draw: ::mixinTest {} run {::Image instproc draw}} {image draw: ::mixinTest {} run {::GrObject instproc draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run draw {::ScrollBarDecorator instproc draw}} {m2 draw: ::mixinTest {} run {::Image instproc draw}} {image draw: ::mixinTest {} run {::GrObject instproc draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run instfilter {::xotcl::Class instforward instfilter}} {filter f: ::xotcl::Object ::xotcl::Class instfilter assign {::xotcl::InterceptorSlot instcmd assign}}" \ + "{filter f: ::mixinTest {} run draw {::MenuDecorator instproc draw}} {m1 draw: ::mixinTest {} run {::ScrollBarDecorator instproc draw}} {m2 draw: ::mixinTest {} run {::Image instproc draw}} {image draw: ::mixinTest {} run {::GrObject instproc draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run draw {::ScrollBarDecorator instproc draw}} {m2 draw: ::mixinTest {} run {::Image instproc draw}} {image draw: ::mixinTest {} run {::GrObject instproc draw}} {grObject draw: ::mixinTest {} run {}} {filter f: ::mixinTest {} run instfilter {::xotcl::Class instforward instfilter}}" \ "Mixin: Calling-Obj/Cl/Proc failed" ::errorCheck $::mixinResult \ - "{filter ::mainImage f ::xotcl::Object} {m1 ::mainImage draw ::MenuDecorator} {m2 ::mainImage draw ::ScrollBarDecorator} {image ::mainImage draw ::Image} {grObject ::mainImage draw ::GrObject} {filter ::zoom f ::xotcl::Object} {m2 ::zoom draw ::ScrollBarDecorator} {image ::zoom draw ::Image} {grObject ::zoom draw ::GrObject} {filter ::xotcl::Object f ::xotcl::Object} {filter ::xotcl::Class::slot::instfilter f ::xotcl::Object}" \ + "{filter ::mainImage f ::xotcl::Object} {m1 ::mainImage draw ::MenuDecorator} {m2 ::mainImage draw ::ScrollBarDecorator} {image ::mainImage draw ::Image} {grObject ::mainImage draw ::GrObject} {filter ::zoom f ::xotcl::Object} {m2 ::zoom draw ::ScrollBarDecorator} {image ::zoom draw ::Image} {grObject ::zoom draw ::GrObject} {filter ::xotcl::Object f ::xotcl::Object}" \ "Mixin: Filter failed" set ::mixinResult ""