Index: TODO =================================================================== diff -u -r451c0d385a7b952b55d12fd02895dfc5ba342293 -r02ec0d2caa6701949f29171520a462564299a611 --- TODO (.../TODO) (revision 451c0d385a7b952b55d12fd02895dfc5ba342293) +++ TODO (.../TODO) (revision 02ec0d2caa6701949f29171520a462564299a611) @@ -1159,13 +1159,20 @@ - fixed "info methods" and added "-methodtype all" for setting class-only - regression test works now until first XOTcl reference +- Changed handling of "child objects": now, they are shown by default. +- At the same time, the subobject "slot" was made protected to avoid + its listing per default in "info methods" +- unified slot parent-object creation handling +- changed XOTcl info to new interface + TODO: +- check "my" vs. "nsf::dispatch" in xotcl2.tcl - overthink decision about not showing "child objects" per default in "info methods" - continue migration nx in regression test -- change info in XOTcl to new interface -- copy info methods to source + - deeper analysis of "contains" - unify SubcmdObj() and ParamCheckObj() handling? +- are "info class*" ops needed? - subcmd * handle sucmd for other method factories @@ -1177,6 +1184,7 @@ # TODO REANIMATE xxxx #::errorCheck $::r "loggingFilter-open open x" {info guarded scope} # (inst)mixinguard, (inst)filterguard +- aliases on procs are a problem, when upvar is used (see info default/instdefault in xotcl2.tcl) - add incompatiblity to migration guide Foo slot ints eval { set :incremental 1; :optimize} Index: generic/xotcl.c =================================================================== diff -u -r4b8cf86fbf103e2d7a014a4942a6486fb77ebd39 -r02ec0d2caa6701949f29171520a462564299a611 --- generic/xotcl.c (.../xotcl.c) (revision 4b8cf86fbf103e2d7a014a4942a6486fb77ebd39) +++ generic/xotcl.c (.../xotcl.c) (revision 02ec0d2caa6701949f29171520a462564299a611) @@ -13871,8 +13871,9 @@ static int AggregatedMethodType(int methodType) { switch (methodType) { case MethodtypeNULL: /* default */ - methodType = XOTCL_METHODTYPE_SCRIPTED|XOTCL_METHODTYPE_BUILTIN; - break; + /* TODO remove comment when settled. + methodType = XOTCL_METHODTYPE_SCRIPTED|XOTCL_METHODTYPE_BUILTIN; + break;*/ case MethodtypeAllIdx: methodType = XOTCL_METHODTYPE_SCRIPTED|XOTCL_METHODTYPE_BUILTIN|XOTCL_METHODTYPE_OBJECT; break; @@ -13881,7 +13882,7 @@ methodType = XOTCL_METHODTYPE_SCRIPTED; break; case MethodtypeBuiltinIdx: - methodType = XOTCL_METHODTYPE_BUILTIN; + methodType = XOTCL_METHODTYPE_BUILTIN|XOTCL_METHODTYPE_OBJECT; break; case MethodtypeForwarderIdx: methodType = XOTCL_METHODTYPE_FORWARDER; Index: library/nx/nx.tcl =================================================================== diff -u -r7cabf9b9a5c54c42dc93a9c631cf0e31edfbc4a5 -r02ec0d2caa6701949f29171520a462564299a611 --- library/nx/nx.tcl (.../nx.tcl) (revision 7cabf9b9a5c54c42dc93a9c631cf0e31edfbc4a5) +++ library/nx/nx.tcl (.../nx.tcl) (revision 02ec0d2caa6701949f29171520a462564299a611) @@ -353,7 +353,7 @@ # if {$scope eq "Class"} { if {![::nsf::objectproperty ${object}::slot object]} { - Object create ${object}::slot + ::nsf::methodproperty $object [Object create ${object}::slot] protected true if {$verbose} {puts stderr "... create object ${object}::slot"} } set o [Object create ${object}::slot::__$w] @@ -469,7 +469,7 @@ # method-modifier for object specific methos :method object {what args} { if {$what in [list "alias" "attribute" "forward" "method" "setter"]} { - return [::nsf::my ::nsf::classes::nx::Object::$what {*}$args] + return [::nsf::dispatch [::nsf::current object] ::nsf::classes::nx::Object::$what {*}$args] } if {$what in [list "info"]} { return [::nsf::dispatch [::nsf::current object] ::nx::Object::slot::__info [lindex $args 0] {*}[lrange $args 1 end]] @@ -494,7 +494,7 @@ } } if {$what in [list "filterguard" "mixinguard"]} { - return [::nsf::my ::nsf::cmd::Object::$what {*}$args] + return [::nsf::dispatch [::nsf::current object] ::nsf::cmd::Object::$what {*}$args] } } @@ -692,14 +692,27 @@ ::nsf::require_method [::nsf::current object] [lindex $args 0] 0 } namespace { - ::nsf::my ::nsf::cmd::Object::requireNamespace + ::nsf::dispatch [::nsf::current object] ::nsf::cmd::Object::requireNamespace } } } + proc ::nx::slotObj {baseObject {name ""}} { + # Create slot parent object if needed + set slotParent ${baseObject}::slot + if {![::nsf::objectproperty $slotParent object]} { + ::nx::Object alloc $slotParent + ::nsf::methodproperty ${baseObject} -per-object slot protected true + } + if {$name eq ""} { + return ${slotParent} + } + return ${slotParent}::$name + } + # allocate system slot parents - Object alloc ::nx::Class::slot - Object alloc ::nx::Object::slot + ::nx::slotObj ::nx::Class + ::nx::slotObj ::nx::Object ######################## # Info definition @@ -753,6 +766,7 @@ :alias "info methods" ::nsf::cmd::ClassInfo2::methods :alias "info mixin guard" ::nsf::cmd::ClassInfo2::mixinguard :alias "info mixin classes" ::nsf::cmd::ClassInfo2::mixinclasses + :alias "info mixinof" ::nsf::cmd::ClassInfo2::mixinof :alias "info slots" ::nsf::cmd::ClassInfo2::slots :alias "info subclass" ::nsf::cmd::ClassInfo2::subclass :alias "info superclass" ::nsf::cmd::ClassInfo2::superclass @@ -761,8 +775,8 @@ # # Define "info info" and unknown # - proc infoOptions {obj} { - puts stderr "$obj INFO '[::nsf::dispatch $obj ::nsf::cmd::ObjectInfo2::methods -methodtype all]'" + proc ::nx::infoOptions {obj} { + #puts stderr "INFO INFO $obj -> '[::nsf::dispatch $obj ::nsf::cmd::ObjectInfo2::methods -methodtype all]'" set methods [list] foreach name [::nsf::dispatch $obj ::nsf::cmd::ObjectInfo2::methods -methodtype all] { if {$name eq "unknown"} continue @@ -775,8 +789,8 @@ error "[::nsf::current object] unknown info option \"$method\"; [$obj info info]" } - Object method "info info" {} {infoOptions ::nx::Object::slot::__info} - Class method "info info" {} {infoOptions ::nx::Class::slot::__info} + Object method "info info" {} {::nx::infoOptions ::nx::Object::slot::__info} + Class method "info info" {} {::nx::infoOptions ::nx::Class::slot::__info} # finally register method "method" (otherwise, we cannot use "method" above) Object alias "info method" ::nsf::cmd::ObjectInfo2::method @@ -839,15 +853,6 @@ Class create ::nx::MetaSlot ::nsf::relation MetaSlot superclass Class - MetaSlot public method slotName {name baseObject} { - # Create slot parent object if needed - set slotParent ${baseObject}::slot - if {![::nsf::objectproperty $slotParent object]} { - ::nx::Object create $slotParent - } - return ${slotParent}::$name - } - MetaSlot method createFromParameterSyntax { target -per-object:switch {-initblock ""} @@ -890,7 +895,7 @@ set info ClassInfo2 } - :create [:slotName $name $target] {*}$opts $initblock + :create [::nx::slotObj $target $name] {*}$opts $initblock return [::nsf::dispatch $target ::nsf::cmd::${info}::method handle $name] } @@ -931,7 +936,7 @@ proc createBootstrapAttributeSlots {class definitions} { foreach att $definitions { if {[llength $att]>1} {foreach {att default} $att break} - set slotObj [::nx::ObjectParameterSlot slotName $att $class] + set slotObj [::nx::slotObj $class $att] ::nx::ObjectParameterSlot create $slotObj if {[info exists default]} { ::nsf::setvar $slotObj default $default @@ -1066,8 +1071,8 @@ ObjectParameterSlot method unknown {method args} { set methods [list] - foreach m [:info callable methods] { - if {[Object info callable methods $m] ne ""} continue + foreach m [::nsf::dispatch [::nsf::current object] ::nsf::cmd::ObjectInfo2::callable methods] { + if {[::nsf::dispatch Object ::nsf::cmd::ObjectInfo2::callable methods $m] ne ""} continue if {[string match __* $m]} continue lappend methods $m } @@ -1608,16 +1613,12 @@ foreach arg $arglist { Attribute createFromParameterSyntax [::nsf::current object] {*}$arg } - # todo needed? - set slot [::nsf::current object]::slot - if {![::nsf::objectproperty $slot object]} {Object create $slot} + set slot [::nx::slotObj [::nsf::current object]] ::nsf::setvar $slot __parameter $arglist } Class method "info parameter" {} { - set class [::nsf::current object] - set slot ${class}::slot - if {![::nsf::objectproperty $slot object]} {Object create $slot} + set slot [::nx::slotObj [::nsf::current object]] if {[::nsf::existsvar $slot __parameter]} { return [::nsf::setvar $slot __parameter] } @@ -1791,19 +1792,19 @@ ::nsf::relation $obj object-mixin [::nsf::relation $origin object-mixin] if {[$origin info hasnamespace]} { # reused in XOTcl, no "require" there, so use nsf primitiva - ::nsf::dispatch $obj ::nsf::cmd::Object::requireNamespace + $obj ::nsf::cmd::Object::requireNamespace } } else { namespace eval $dest {} } :copyNSVarsAndCmds $origin $dest - foreach i [::nsf::dispatch $origin ::nsf::cmd::ObjectInfo2::forward] { - ::nsf::forward $dest -per-object $i {*}[::nsf::dipatch $origin ::nsf::cmd::ObjectInfo2::forward -definition $i] + foreach i [$origin ::nsf::cmd::ObjectInfo2::forward] { + ::nsf::forward $dest -per-object $i {*}[$origin ::nsf::cmd::ObjectInfo2::forward -definition $i] } if {[::nsf::objectproperty $origin class]} { - foreach i [nsf::dispatch $origin ::nsf::cmd::ClassInfo2::forward] { - ::nsf::forward $dest $i {*}[::nsf::dipatch $origin ::nsf::cmd::ClassInfo2::forward -definition $i] + foreach i [$origin ::nsf::cmd::ClassInfo2::forward] { + ::nsf::forward $dest $i {*}[$origin ::nsf::cmd::ClassInfo2::forward -definition $i] } } set traces [list] @@ -1827,7 +1828,7 @@ if {[::nsf::objectproperty $origin class]} { set dest [:getDest $origin] foreach oldslot [$origin info slots] { - set newslot [Slot slotName [namespace tail $oldslot] $dest] + set newslot [::nx::slotObj $dest [namespace tail $oldslot]] if {[$oldslot domain] eq $origin} {$newslot domain $cl} if {[$oldslot manager] eq $oldslot} {$newslot manager $newslot} } @@ -1915,3 +1916,4 @@ unset bootstrap } + Index: library/serialize/serializer.tcl =================================================================== diff -u -r033c63d771af5253b0e94c2a9c1c6a94df40242e -r02ec0d2caa6701949f29171520a462564299a611 --- library/serialize/serializer.tcl (.../serializer.tcl) (revision 033c63d771af5253b0e94c2a9c1c6a94df40242e) +++ library/serialize/serializer.tcl (.../serializer.tcl) (revision 02ec0d2caa6701949f29171520a462564299a611) @@ -664,7 +664,7 @@ [::nsf::dispatch $o -objscope ::nsf::current object]] append cmd " -noinit\n" - foreach i [lsort [::nsf::cmd::ObjectInfo::methods $o]] { + foreach i [lsort [$o ::nsf::cmd::ObjectInfo2::methods]] { append cmd [:method-serialize $o $i "object"] "\n" } append cmd \ @@ -689,7 +689,7 @@ :method Class-serialize {o s} { set cmd [:Object-serialize $o $s] - foreach i [lsort [::nsf::cmd::ClassInfo::methods $o]] { + foreach i [lsort [$o ::nsf::cmd::ClassInfo2::methods]] { append cmd [:method-serialize $o $i ""] "\n" } append cmd \ @@ -772,6 +772,7 @@ set arglist [list] foreach v [$o info ${prefix}args $m] { if {[$o info ${prefix}default $m $v x]} { + #puts "... [list $o info ${prefix}default $m $v x] returned 1, x?[info exists x] level=[info level]" lappend arglist [list $v $x] } {lappend arglist $v} } lappend r $o ${prefix}proc $m \ @@ -793,13 +794,13 @@ # slots needs to be initialized when optimized, since # parametercmds are not serialized append cmd " -noinit\n" - foreach i [::nsf::cmd::ObjectInfo::methods $o -methodtype scripted] { + foreach i [$o ::nsf::cmd::ObjectInfo2::methods -methodtype scripted] { append cmd [:method-serialize $o $i ""] "\n" } - foreach i [::nsf::cmd::ObjectInfo::methods $o -methodtype forward] { + foreach i [$o ::nsf::cmd::ObjectInfo2::methods -methodtype forward] { append cmd [concat [list $o] forward $i [$o info forward -definition $i]] "\n" } - foreach i [::nsf::cmd::ObjectInfo::methods $o -methodtype setter] { + foreach i [$o ::nsf::cmd::ObjectInfo2::methods -methodtype setter] { append cmd [list $o parametercmd $i] "\n" } append cmd \ @@ -828,8 +829,8 @@ append cmd [list $o instparametercmd $i] "\n" } # provide limited support for exporting aliases for XOTcl objects - foreach i [::nsf::cmd::ClassInfo::methods $o -methodtype alias] { - set xotcl2Def [::nsf::cmd::ClassInfo::method $o definition $i] + foreach i [$o ::nsf::cmd::ClassInfo2::methods -methodtype alias] { + set xotcl2Def [$o ::nsf::cmd::ClassInfo2::method definition $i] set objscope [lindex $xotcl2Def end-2] set methodName [lindex $xotcl2Def end-1] set cmdName [lindex $xotcl2Def end] Index: library/xotcl/library/xotcl2.tcl =================================================================== diff -u -radc4affd14701109f5d9b655dddf58d6b42cd781 -r02ec0d2caa6701949f29171520a462564299a611 --- library/xotcl/library/xotcl2.tcl (.../xotcl2.tcl) (revision adc4affd14701109f5d9b655dddf58d6b42cd781) +++ library/xotcl/library/xotcl2.tcl (.../xotcl2.tcl) (revision 02ec0d2caa6701949f29171520a462564299a611) @@ -157,9 +157,9 @@ # Calling upon this method during object construction allows you to # bypass the constructor method: # {{{ - # Class create C - # C instproc init {} {puts stderr "A class-specific constructor shouts out ..."} - # C c1 -noinit + # Class create C + # C instproc init {} {puts stderr "A class-specific constructor shouts out ..."} + # C c1 -noinit # }}} # This bypassing feature comes handy when streaming an object into a # scripted form (e.g., by using the bundled Serializer). Upon @@ -182,15 +182,15 @@ # Tcl namespaces which shadow an existing object (i.e., carry the same # name): # {{{ - # Object create Foo - # Foo requireNamespace - # namespace exists Foo; # returns 1 - # Foo info hasnamespace; # returns 1 + # Object create Foo + # Foo requireNamespace + # namespace exists Foo; # returns 1 + # Foo info hasnamespace; # returns 1 # - # Object create Bar - # namespace eval ::Bar {} - # namespace exists Bar; # returns 1 - # Bar info hasnamespace; # returns 0 + # Object create Bar + # namespace eval ::Bar {} + # namespace exists Bar; # returns 1 + # Bar info hasnamespace; # returns 0 # }}} # @method ::xotcl::Object#vwait @@ -219,6 +219,20 @@ ::nsf::methodproperty Class dealloc redefine-protected true ::nsf::methodproperty Class create redefine-protected true + # + # define parametercmd and instparametercmd in terms of ::nx method setter + # define filterguard and instfilterguard in terms of filterguard + # define mixinguard and instmixinguard in terms of mixinguard + # + ::nsf::alias Object parametercmd ::nsf::classes::nx::Object::setter + ::nsf::alias Class instparametercmd ::nsf::classes::nx::Class::setter + + ::nsf::alias Object filterguard ::nsf::cmd::Object::filterguard + ::nsf::alias Class instfilterguard ::nsf::cmd::Class::filterguard + + ::nsf::alias Object mixinguard ::nsf::cmd::Object::mixinguard + ::nsf::alias Class instmixinguard ::nsf::cmd::Class::mixinguard + # define instproc and proc ::nsf::method Class instproc { name arguments body precondition:optional postcondition:optional @@ -238,7 +252,7 @@ ::nsf::method [self] -per-object $name $arguments $body {*}$conditions } - # define - like in XOTcl 1 - a minimal implementation of "method" + # define a minimal implementation of "method" Object instproc method {name arguments body} { :proc $name $arguments $body } @@ -329,35 +343,13 @@ Object create ::xotcl::objectInfo Object create ::xotcl::classInfo - # note, we are using ::xotcl::infoError defined earlier - Object instforward info -onerror ::nsf::infoError ::xotcl::objectInfo %1 {%@2 %self} - Class instforward info -onerror ::nsf::infoError ::xotcl::classInfo %1 {%@2 %self} + # note, we are using ::nsf::infoError, defined my nsf + #Object instforward info -onerror ::nsf::infoError ::xotcl::objectInfo %1 {%@2 %self} + #Class instforward info -onerror ::nsf::infoError ::xotcl::classInfo %1 {%@2 %self} - objectInfo proc info {obj} { - set methods [list] - foreach name [::nsf::cmd::ObjectInfo::methods ::xotcl::objectInfo] { - if {$name eq "unknown"} continue - lappend methods $name - } - return "valid options are: [join [lsort $methods] {, }]" - } - objectInfo proc unknown {method args} { - error "[::xotcl::self] unknown info option \"$method\"; [:info info]" - } + ::nsf::alias Object info ::xotcl::objectInfo + ::nsf::alias Class info ::xotcl::classInfo - classInfo proc info {cl} { - set methods [list] - foreach name [::nsf::cmd::ObjectInfo::methods ::xotcl::classInfo] { - if {$name eq "unknown"} continue - lappend methods $name - } - return "valid options are: [join [lsort $methods] {, }]" - } - - classInfo proc unknown {method args} { - error "[::xotcl::self] unknown info option \"$method\"; [:info info]" - } - # # Backward compatibility info subcommands; # @@ -404,8 +396,8 @@ proc ::xotcl::info_args {allocation o method} { set result [list] foreach \ - argName [::nsf::cmd::${allocation}Info::method $o args $method] \ - flag [::nsf::cmd::${allocation}Info::method $o parameter $method] { + argName [$o ::nsf::cmd::${allocation}Info2::method args $method] \ + flag [$o ::nsf::cmd::${allocation}Info2::method parameter $method] { if {[string match -* $flag]} continue lappend result $argName } @@ -415,7 +407,7 @@ proc ::xotcl::info_nonposargs {allocation o method} { set result [list] - foreach flag [::nsf::cmd::${allocation}Info::method $o parameter $method] { + foreach flag [$o ::nsf::cmd::${allocation}Info2::method parameter $method] { if {![string match -* $flag]} continue lappend result $flag } @@ -424,184 +416,192 @@ } proc ::xotcl::info_default {allocation o method arg varName} { foreach \ - argName [::nsf::cmd::${allocation}Info::method $o args $method] \ - flag [::nsf::cmd::${allocation}Info::method $o parameter $method] { + argName [$o ::nsf::cmd::${allocation}Info2::method args $method] \ + flag [$o ::nsf::cmd::${allocation}Info2::method parameter $method] { if {$argName eq $arg} { - upvar 3 $varName default + upvar 2 $varName default + #puts "--- info_default var '$varName' level=[info level]" if {[llength $flag] == 2} { set default [lindex $flag 1] - #puts stderr "--- get ${inst}default for $o $method $arg => $default" + #puts stderr "--- get $allocation default for $o $method $arg => $default" return 1 } - #puts stderr "--- get ${inst}default for $o $method $arg fails" + #puts stderr "--- get $allocation default for $o $method $arg fails" set default "" return 0 } } error "procedure \"$method\" doesn't have an argument \"$varName\"" } - classInfo eval { - :proc instargs {o method} {::xotcl::info_args Class $o $method} - :proc args {o method} {::xotcl::info_args Object $o $method} - :proc instnonposargs {o method} {::xotcl::info_nonposargs Class $o $method} - :proc nonposargs {o method} {::xotcl::info_nonposargs Object $o $method} - :proc instdefault {o method arg var} {::xotcl::info_default Class $o $method $arg $var} - :proc default {o method arg var} {::xotcl::info_default Object $o $method $arg $var} + # define temporary method "alias" + Object instproc alias {name cmd} {::nsf::alias [self] $name $cmd} - # info options emulated by "info method ..." - :proc instbody {o methodName} {::nsf::cmd::ClassInfo::method $o body $methodName} - :proc instpre {o methodName} {::nsf::cmd::ClassInfo::method $o precondition $methodName} - :proc instpost {o methodName} {::nsf::cmd::ClassInfo::method $o postcondition $methodName} - - # info options emulated by "info methods" - :proc instcommands {o {pattern:optional ""}} { - ::nsf::cmd::ClassInfo::methods $o {*}$pattern + objectInfo eval { + :proc args {method} {::xotcl::info_args Object [self] $method} + :proc body {methodName} {my ::nsf::cmd::ObjectInfo2::method body $methodName} + :proc check {} {::xotcl::checkoption_internal_to_xotcl1 [::nsf::assertion [self] check]} + :alias class ::nsf::cmd::ObjectInfo2::class + :alias children ::nsf::cmd::ObjectInfo2::children + :proc commands {{pattern ""}} { + my ::nsf::cmd::ObjectInfo2::methods -methodtype all {*}$pattern } - :proc instprocs {o {pattern:optional ""}} { - ::nsf::cmd::ClassInfo::methods $o -methodtype scripted {*}$pattern + :proc default {method arg varName} { + # pass varName to be able produce the right error message + set r [::xotcl::info_default Object [self] $method $arg $varName] + #puts "--- var '$varName' level=[info level]" + return $r } - :proc parametercmd {o {pattern:optional ""}} { - ::nsf::cmd::ClassInfo::methods $o -per-object -methodtype setter {*}$pattern + :proc filter {-order:switch -guards:switch pattern:optional} { + set guardsFlag [expr {$guards ? "-guards" : ""}] + set patternArg [expr {[info exists pattern] ? [list $pattern] : ""}] + if {$order && !$guards} { + set def [::nsf::dispatch [::nsf::current object] \ + ::nsf::cmd::ObjectInfo2::filtermethods -order \ + {*}$guardsFlag \ + {*}$patternArg] + set def [method_handles_to_xotcl $def] + } else { + set def [::nsf::dispatch [::nsf::current object] \ + ::nsf::cmd::ObjectInfo2::filtermethods \ + {*}$guardsFlag \ + {*}$patternArg] + } + #puts stderr " => $def" + return $def } - :proc instparametercmd {o {pattern:optional ""}} { - ::nsf::cmd::ClassInfo::methods $o -methodtype setter {*}$pattern - } - # filter handling - :proc instfilter {o args} {::nsf::dispatch $o ::nsf::cmd::ClassInfo2::filtermethods {*}$args} - :proc filterguard {o filter} {::nsf::dispatch $o ::nsf::cmd::ObjectInfo2::filterguard $filter} - :proc instfilterguard {o filter} {::nsf::dispatch $o ::nsf::cmd::ClassInfo2::filterguard $filter} - :proc mixin {o args} {::nsf::dispatch $o ::nsf::cmd::ObjectInfo2::mixinclasses {*}$args} - :proc mixinguard {o mixin} {::nsf::dispatch $o ::nsf::cmd::ObjectInfo2::mixinguard $mixin} - :proc instmixin {o args} {::nsf::dispatch $o ::nsf::cmd::ClassInfo2::mixinclasses {*}$args} - :proc instmixinguard {o mixin} {::nsf::dispatch $o ::nsf::cmd::ClassInfo2::mixinguard $mixin} + :alias filterguard ::nsf::cmd::ObjectInfo2::filterguard + :alias forward ::nsf::cmd::ObjectInfo2::forward + :alias hasnamespace ::nsf::cmd::ObjectInfo2::hasnamespace + :proc invar {} {::nsf::assertion [self] object-invar} + #:proc is {kind value:optional} {::nsf::objectproperty [::nsf::current object] $kind {*}$value} - # assertion handling - :proc instinvar {o} {::nsf::assertion $o class-invar} - } - - objectInfo eval { - :proc args {o method} {::xotcl::info_args Object $o $method} - :proc nonposargs {o method} {::xotcl::info_nonposargs Object $o $method} - :proc default {o method arg var} {::xotcl::info_default Object $o $method $arg $var} - - # info options emulated by "info method ..." - :proc body {o methodName} {::nsf::cmd::ObjectInfo::method $o body $methodName} - :proc pre {o methodName} {::nsf::cmd::ObjectInfo::method $o pre $methodName} - :proc post {o methodName} {::nsf::cmd::ObjectInfo::method $o post $methodName} - - # info options emulated by "info methods" - :proc commands {o {pattern:optional ""}} { - ::nsf::cmd::ObjectInfo::methods $o -methodtype all {*}$pattern - } - :proc procs {o {pattern:optional ""}} { - ::nsf::cmd::ObjectInfo::methods $o -methodtype scripted {*}$pattern - } :proc methods { - o -nocmds:switch -noprocs:switch -incontext:switch pattern:optional + -nocmds:switch -noprocs:switch -incontext:switch pattern:optional } { set methodtype all if {$nocmds} {set methodtype scripted} if {$noprocs} {if {$nocmds} {return ""}; set methodtype builtin} - set cmd [list ::nsf::cmd::ObjectInfo::callable $o methods -methodtype $methodtype] + set cmd [list ::nsf::cmd::ObjectInfo2::callable methods -methodtype $methodtype] if {$incontext} {lappend cmd -incontext} if {[info exists pattern]} {lappend cmd $pattern} - eval $cmd + my {*}$cmd } - # filter handling - :proc filter {o -order:switch -guards:switch pattern:optional} { - set guardsFlag [expr {$guards ? "-guards" : ""}] - set patternArg [expr {[info exists pattern] ? [list $pattern] : ""}] - if {$order && !$guards} { - set def [::nsf::dispatch $o ::nsf::cmd::ObjectInfo2::filtermethods -order {*}$guardsFlag {*}$patternArg] - set def [method_handles_to_xotcl $def] - } else { - set def [::nsf::dispatch $o ::nsf::cmd::ObjectInfo2::filtermethods {*}$guardsFlag {*}$patternArg] - } - #puts stderr " => $def" - return $def + :alias mixin ::nsf::cmd::ObjectInfo2::mixinclasses + :alias mixinguard ::nsf::cmd::ObjectInfo2::mixinguard + :proc nonposargs {method} {::xotcl::info_nonposargs Object [self] $method} + :proc parametercmd {name} {::nsf::classes::nx::Object::setter [self] $name} + :alias parent ::nsf::cmd::ObjectInfo2::parent + :proc post {methodName} {my ::nsf::cmd::ObjectInfo2::method post $methodName} + :proc pre {methodName} {my ::nsf::cmd::ObjectInfo2::method pre $methodName} + :proc procs {{pattern ""}} { + my ::nsf::cmd::ObjectInfo2::methods -methodtype scripted {*}$pattern } - :proc mixin {o args} {::nsf::dispatch $o ::nsf::cmd::ObjectInfo2::mixinclasses {*}$args} - :proc filterguard {o filter} {::nsf::dispatch $o ::nsf::cmd::ObjectInfo2::filterguard $filter} - :proc mixinguard {o mixin} {::nsf::dispatch $o ::nsf::cmd::ObjectInfo2::mixinguard $mixin} - - # assertion handling - :proc check {o} { - ::xotcl::checkoption_internal_to_xotcl1 [::nsf::assertion $o check] - } - :proc invar {o} {::nsf::assertion $o object-invar} + :alias precedence ::nsf::cmd::ObjectInfo2::precedence + :alias vars ::nsf::cmd::ObjectInfo2::vars } - foreach cmd [::info command ::nsf::cmd::ObjectInfo::*] { - set cmdName [namespace tail $cmd] - if {$cmdName in [list "callable" "filter" "method" "methods"]} continue - ::nsf::alias ::xotcl::objectInfo $cmdName $cmd - ::nsf::alias ::xotcl::classInfo $cmdName $cmd + # + # copy all methods from Object.info to Class.info + # + foreach m [objectInfo ::nsf::cmd::ObjectInfo2::methods] { + ::nsf::alias classInfo $m [objectInfo ::nsf::cmd::ObjectInfo2::method handle $m] } - foreach cmd [::info command ::nsf::cmd::ClassInfo::*] { - set cmdName [namespace tail $cmd] - if {$cmdName in [list "forward" "method" "methods" \ - "mixinof" "object-mixin-of" \ - "filter" "filterguard" \ - "mixin" "mixinguard"]} continue - ::nsf::alias ::xotcl::classInfo $cmdName $cmd - } + classInfo eval { + :alias classchildren ::nsf::cmd::ObjectInfo2::children + :alias classparent ::nsf::cmd::ObjectInfo2::parent + :proc default {method arg varName} { + # TODO: interesting observation: we cannot use the alias to + # objectInfo here, but we have to rewrite the proc, since an + # alias introduces currently a new frame, which would require a + # "upvar 2 ..." + set r [::xotcl::info_default Object [self] $method $arg $varName] + #puts "--- var '$varName' level=[info level]" + return $r + } + :alias heritage ::nsf::cmd::ClassInfo2::heritage + :alias instances ::nsf::cmd::ClassInfo2::instances - ::nsf::alias ::xotcl::objectInfo is ::nsf::objectproperty + :proc instargs {method} {::xotcl::info_args Class [self] $method} + :proc instbody {methodName} {my ::nsf::cmd::ClassInfo2::method body $methodName} + :proc instcommands {{pattern ""}} {my ::nsf::cmd::ClassInfo2::methods {*}$pattern} + :proc instdefault {method arg varName} { + set r [::xotcl::info_default Class [self] $method $arg $varName] + #puts "--- default for [self].$method $arg -> $r [info exists var]" + #puts "--- var '$var' level=[info level]" + #puts "--- level 0 [info level [info level]]" + #puts "--- level -1 [info level [expr [info level]-1]]" + #puts "--- level -2 [info level [expr [info level]-2]]" + return $r + } + :alias instfilter ::nsf::cmd::ClassInfo2::filtermethods + :alias instfilterguard ::nsf::cmd::ClassInfo2::filterguard + :alias instforward ::nsf::cmd::ClassInfo2::forward - ::nsf::alias ::xotcl::classInfo is ::nsf::objectproperty - ::nsf::alias ::xotcl::classInfo classparent ::nsf::cmd::ObjectInfo::parent - ::nsf::alias ::xotcl::classInfo classchildren ::nsf::cmd::ObjectInfo::children + :proc instinvar {} {::nsf::assertion [self] class-invar} + :alias instmixin ::nsf::cmd::ClassInfo2::mixinclasses + :alias instmixinguard ::nsf::cmd::ClassInfo2::mixinguard + :proc instmixinof {-closure {pattern ""}} { + my ::nsf::cmd::ClassInfo2::mixinof -scope class \ + {*}[expr {$closure ? "-closure" : ""}] \ + {*}$pattern + } + :proc instparametercmd {{pattern ""}} { + my ::nsf::cmd::ClassInfo2::methods -methodtype setter {*}$pattern + } + :proc instnonposargs {method} {::xotcl::info_nonposargs Class [self] $method} + :proc instpost {methodName} {my ::nsf::cmd::ClassInfo2::method postcondition $methodName} + :proc instpre {methodName} {my ::nsf::cmd::ClassInfo2::method precondition $methodName} - ::nsf::forward ::xotcl::classInfo instmixinof ::nsf::cmd::ClassInfo::mixinof %1 -scope class - ::nsf::alias ::xotcl::classInfo instforward ::nsf::cmd::ClassInfo::forward - ::nsf::forward ::xotcl::classInfo mixinof ::nsf::cmd::ClassInfo::mixinof %1 -scope object - ::nsf::alias ::xotcl::classInfo parameter ::nx::classInfo::parameter + :proc instprocs {{pattern ""}} { + my ::nsf::cmd::ClassInfo2::methods -methodtype scripted {*}$pattern + } + :proc mixinof {-closure:switch {pattern ""}} { + my ::nsf::cmd::ClassInfo2::mixinof -scope object \ + {*}[expr {$closure ? "-closure" : ""}] \ + {*}$pattern + } + :alias parameter ::nx::Class::slot::__info::parameter + :alias slots ::nsf::cmd::ClassInfo2::slots + :alias subclass ::nsf::cmd::ClassInfo2::subclass + :alias superclass ::nsf::cmd::ClassInfo2::superclass + } - # assertion handling - ::nsf::alias ::xotcl::classInfo invar objectInfo::invar - ::nsf::alias ::xotcl::classInfo check objectInfo::check + # define "info info" + objectInfo method info {} {::nx::infoOptions ::xotcl::objectInfo} + classInfo method info {} {::nx::infoOptions ::xotcl::classInfo} - # define info methods from objectInfo on classInfo as well - ::nsf::alias classInfo body objectInfo::body - ::nsf::alias classInfo commands objectInfo::commands - ::nsf::alias classInfo filter objectInfo::filter - ::nsf::alias classInfo methods objectInfo::methods - ::nsf::alias classInfo procs objectInfo::procs - ::nsf::alias classInfo pre objectInfo::pre - ::nsf::alias classInfo post objectInfo::post + # define "info unknown" + objectInfo proc unknown {method args} { + error "[::xotcl::self] unknown info option \"$method\"; [:info info]" + } + classInfo proc unknown {method args} { + error "[::xotcl::self] unknown info option \"$method\"; [:info info]" + } - # emulation of isobject, isclass ... + # + # end if info + # + + # remove temporary method "alias" + Object instproc alias {} {} + + # emulation of isobject, isclass ... Object instproc isobject {{object:substdefault "[self]"}} {::nsf::objectproperty $object object} Object instproc isclass {{class:substdefault "[self]"}} {::nsf::objectproperty $class class} Object instproc ismetaclass {{class:substdefault "[self]"}} {::nsf::objectproperty $class metaclass} Object instproc ismixin {class} {::nsf::is [self] object -hasmixin $class} Object instproc istype {class} {::nsf::is [self] type $class} + # definitin of "contains", based on nx + ::nsf::alias Object contains ::nsf::classes::nx::Object::contains ::xotcl::Class instforward slots %self contains \ -object {%::nsf::dispatch [::xotcl::self] -objscope ::subst [::xotcl::self]::slot} - # - # define parametercmd and instparametercmd in terms of ::nx method setter - # define filterguard and instfilterguard in terms of filterguard - # define mixinguard and instmixinguard in terms of mixinguard - # - ::nsf::alias Object parametercmd ::nsf::classes::nx::Object::setter - ::nsf::alias Class instparametercmd ::nsf::classes::nx::Class::setter - # @method ::xotcl::Class#mixinguard - # - # @param mixin - # @param guard - - # @method ::nx::Class#instmixinguard - # - # @param mixin - # @param guard - # assertion handling proc checkoption_xotcl1_to_internal checkoptions { set options [list] @@ -687,21 +687,14 @@ if {[::nsf::is [self] object -hasmixin $cl]} {return 1} ::nsf::is [self] type $cl } - - # @method ::nx::Object#filtersearch - # - # Search a fully qualified method name which is currently registered - # as a filter. - # - # @param filter Handle to identify and address a filter once registered - # @param guard A list of guard expressions - # @return A list in proc qualifier format: 'objName|className proc|instproc methodName'. Object instproc filtersearch {filter} { - set handle [::nsf::cmd::ObjectInfo::callable [self] filter $filter] + set handle [::nsf::dispatch [::nsf::current object] \ + ::nsf::cmd::ObjectInfo2::callable filter $filter] return [method_handle_to_xotcl $handle] } Object instproc procsearch {name} { - set handle [::nsf::cmd::ObjectInfo::callable [self] method $name] + set handle [::nsf::dispatch [::nsf::current object] \ + ::nsf::cmd::ObjectInfo2::callable method $name] return [method_handle_to_xotcl $handle] } Class instproc allinstances {} { @@ -967,4 +960,4 @@ foreach ns {::nsf ::nx ::xotcl} { puts stderr "$ns exports [namespace eval $ns {lsort [namespace export]}]" -} \ No newline at end of file +} Index: library/xotcl/tests/testx.xotcl =================================================================== diff -u -re849d060161385466c782e46c19344428934cd7f -r02ec0d2caa6701949f29171520a462564299a611 --- library/xotcl/tests/testx.xotcl (.../testx.xotcl) (revision e849d060161385466c782e46c19344428934cd7f) +++ library/xotcl/tests/testx.xotcl (.../testx.xotcl) (revision 02ec0d2caa6701949f29171520a462564299a611) @@ -348,25 +348,25 @@ set erg [f${i} a] ::errorCheck $::result "{in a-::SB($i)::fb} {in a-::Filtered${i}::testfilter}" \ "Filter Test - remove" - + f${i} proc procFilter args { return "[next]-[self class]::[self proc]" } f${i} filter {fa f2 procFilter} - + set ::result "" set erg [f${i} a] ::errorCheck $::result "{in a-::SB($i)::fb} {in a-::Filtered${i}::testfilter} {in a-::procFilter-::SB($i)::f2} {in a-::procFilter-::SA($i)::fa}" \ "Obj Filter Test call three filter + instfilter" - + ::errorCheck [f${i} info filter]-[SB($i) info instfilter]-[SC($i) info instfilter] \ "fa f2 procFilter-::procFilter-fb-" \ "filter infos" - + ::errorCheck [f${i} filtersearch fa]-[f${i} filtersearch fb]-[f${i} filtersearch procFilter] \ "::SA($i) instproc fa-::procFilter-::SB($i) instproc fb-::procFilter-::f${i} proc procFilter-::procFilter" \ "filtersearch" - + Filtered${i} instfilter {} SB($i) instfilter {} @@ -2583,6 +2583,7 @@ X::Y::Z z X::Y::Z copy V + V v ::errorCheck "[z q 1 2 3]--[X::Y::Z info class]--[X::Y::Z info classparent]" \ "::z--::X::Y::Z--q------::xotcl::Class--::X::Y"\ @@ -3359,7 +3360,7 @@ ::errorCheck [o mixin XY4] ::XY4 " __unknown XY4" } - ::errorCheck [UnknownClass info info] {valid options are: args, body, check, children, class, classchildren, classparent, commands, default, filter, filterguard, forward, hasnamespace, heritage, info, instances, instargs, instbody, instcommands, instdefault, instfilter, instfilterguard, instforward, instinvar, instmixin, instmixinguard, instmixinof, instnonposargs, instparametercmd, instpost, instpre, instprocs, invar, is, methods, mixin, mixinguard, mixinof, nonposargs, parameter, parametercmd, parent, post, pre, precedence, procs, slotobjects, slots, subclass, superclass, vars} "UnknownClass info info" + ::errorCheck [UnknownClass info info] {valid options are: args, body, check, children, class, classchildren, classparent, commands, default, filter, filterguard, forward, hasnamespace, heritage, info, instances, instargs, instbody, instcommands, instdefault, instfilter, instfilterguard, instforward, instinvar, instmixin, instmixinguard, instmixinof, instnonposargs, instparametercmd, instpost, instpre, instprocs, invar, methods, mixin, mixinguard, mixinof, nonposargs, parameter, parametercmd, parent, post, pre, precedence, procs, slots, subclass, superclass, vars} "UnknownClass info info" # clear unknown handler to avoid strange results later Class proc __unknown "" "" @@ -3400,7 +3401,7 @@ ::errorCheck [e1 exists X] "1" "forward 3" ::errorCheck [e1 q] q "self proc" - ::errorCheck [lsort [E info commands]] {p slot} "class commands" + ::errorCheck [lsort [E info commands]] {p} "class commands" ::errorCheck [lsort [E info instcommands]] "q t x" "class instcommands" ::errorCheck [E info instbody t] "return ok" "class info instbody" @@ -4090,7 +4091,7 @@ "Defaults for instproc" catch {C info instdefault m2 xxx e} msg - errorCheck $msg {procedure "info m2" doesn't have an argument "e"} \ + errorCheck $msg {procedure "m2" doesn't have an argument "e"} \ "Defaults instproc error" C instproc m3 {