Index: generic/gentclAPI.decls =================================================================== diff -u -r04747ba752ca2b7a4f30586348e39ab04f190da9 -rbf9bae94d157de9bbd4c398f6a3a9a4d93626025 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision 04747ba752ca2b7a4f30586348e39ab04f190da9) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision bf9bae94d157de9bbd4c398f6a3a9a4d93626025) @@ -143,7 +143,7 @@ objectMethod invar XOTclOInvariantsMethod { {-argName "invariantlist" -required 1 -type tclobj} } -objectMethod method XOTclOMethodMethod { +objectMethod object-method XOTclOMethodMethod { {-argName "-inner-namespace"} {-argName "-public"} {-argName "name" -required 1 -type tclobj} @@ -211,9 +211,8 @@ {-argName "mixin" -required 1} {-argName "guard" -required 1 -type tclobj} } -classMethod method XOTclCMethodMethod { +classMethod class-method XOTclCMethodMethod { {-argName "-inner-namespace" -type switch} - {-argName "-per-object" -type switch} {-argName "-public"} {-argName "name" -required 1 -type tclobj} {-argName "args" -required 1 -type tclobj} Index: generic/predefined.h =================================================================== diff -u -r88ef0a6d60c84d75b1436e8cc0e8f8f5d176328e -rbf9bae94d157de9bbd4c398f6a3a9a4d93626025 --- generic/predefined.h (.../predefined.h) (revision 88ef0a6d60c84d75b1436e8cc0e8f8f5d176328e) +++ generic/predefined.h (.../predefined.h) (revision bf9bae94d157de9bbd4c398f6a3a9a4d93626025) @@ -6,10 +6,12 @@ "::xotcl::createobjectsystem ::xotcl2::Object ::xotcl2::Class\n" "foreach cmd [info command ::xotcl::cmd::Object::*] {\n" "set cmdName [namespace tail $cmd]\n" -"if {$cmdName in [list \"instvar\"]} continue\n" +"if {$cmdName in [list \"instvar\" \"object-method\"]} continue\n" "::xotcl::alias Object $cmdName $cmd}\n" "foreach cmd [info command ::xotcl::cmd::Class::*] {\n" -"::xotcl::alias Class [namespace tail $cmd] $cmd}\n" +"set cmdName [namespace tail $cmd]\n" +"if {$cmdName in [list \"class-method\"]} continue\n" +"::xotcl::alias Class $cmdName $cmd}\n" "foreach cmd [list __next cleanup noinit residualargs] {\n" "::xotcl::methodproperty Object $cmd protected 1}\n" "foreach cmd [list recreate] {\n" @@ -18,15 +20,38 @@ "::xotcl::methodproperty Class alloc static true\n" "::xotcl::methodproperty Class dealloc static true\n" "::xotcl::methodproperty Class create static true\n" +"::xotcl::dispatch Class ::xotcl::cmd::Class::class-method method {\n" +"-per-object:switch -public:switch -protected:switch\n" +"name arguments body -precondition -postcondition} {\n" +"set conditions [list]\n" +"if {[info exists precondition]} {lappend conditions -precondition $precondition}\n" +"if {[info exists postcondition]} {lappend conditions -postcondition $postcondition}\n" +"if {${per-object}} {\n" +"set cls Object\n" +"set prefix object} else {\n" +"set cls Class\n" +"set prefix class}\n" +"::xotcl::dispatch [self] ::xotcl::cmd::${cls}::$prefix-method \\\n" +"$name $arguments $body {*}$conditions\n" +"if {$protected} {::xotcl::methodproperty [self] $name protected true}}\n" +"::xotcl::dispatch Object ::xotcl::cmd::Class::class-method method {\n" +"-public:switch -protected:switch\n" +"name arguments body -precondition -postcondition} {\n" +"set conditions [list]\n" +"if {[info exists precondition]} {lappend conditions -precondition $precondition}\n" +"if {[info exists postcondition]} {lappend conditions -postcondition $postcondition}\n" +"::xotcl::dispatch [self] ::xotcl::cmd::Object::object-method \\\n" +"$name $arguments $body {*}$conditions\n" +"if {$protected} {::xotcl::methodproperty [self] $name -per-object protected true}}\n" "Class method unknown {args} {\n" "puts stderr \"use '[self] create $args', not '[self] $args'\"\n" "eval my create $args}\n" "Object method unknown {m args} {\n" "if {![self isnext]} {\n" "error \"[self]: unable to dispatch method '$m'\"}}\n" -"Object method init args {}\n" +"Object method -protected init args {}\n" "Object method defaultmethod {} {::xotcl::self}\n" -"Object method objectparameter {} {;}\n" +"Object method -protected objectparameter {} {;}\n" "Class method -per-object __unknown {name} {}\n" "Object method -public alias {-objscope:switch -protected:switch methodName cmd} {\n" "::xotcl::alias [self] $methodName \\\n" @@ -123,7 +148,7 @@ "unset arg}\n" "lappend parameterdefinitions $parameterdefinition}\n" "return $parameterdefinitions}\n" -"::xotcl2::Object method objectparameter {} {\n" +"::xotcl2::Object method -protected objectparameter {} {\n" "set parameterdefinitions [::xotcl::parametersFromSlots [self]]\n" "if {[::xotcl::is [self] class]} {\n" "lappend parameterdefinitions -parameter:method,optional}\n" @@ -319,7 +344,7 @@ "if {[set .defaultmethods] ne {get assign}} return\n" "if {[.info callable -which assign] ne \"::xotcl::Slot alias assign ::xotcl::setinstvar\"} return\n" "if {[.info callable -which get] ne \"::xotcl::Slot alias get ::xotcl::setinstvar\"} return\n" -"${.domain} setter {*}[expr {${.per-object} ? \"-per-object\" : \"\"}] ${.name}}}\n" +"::xotcl::dispatch ${.domain} ::xotcl::cmd::Class::setter {*}[expr {${.per-object} ? \"-per-object\" : \"\"}] ${.name}}}\n" "::xotcl::Attribute mixin add ::xotcl::Slot::Optimizer\n" "::xotcl2::Class create ::xotcl::ScopedNew -superclass ::xotcl2::Class\n" "createBootstrapAttributeSlots ::xotcl::ScopedNew {\n" Index: generic/predefined.xotcl =================================================================== diff -u -r88ef0a6d60c84d75b1436e8cc0e8f8f5d176328e -rbf9bae94d157de9bbd4c398f6a3a9a4d93626025 --- generic/predefined.xotcl (.../predefined.xotcl) (revision 88ef0a6d60c84d75b1436e8cc0e8f8f5d176328e) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision bf9bae94d157de9bbd4c398f6a3a9a4d93626025) @@ -17,7 +17,7 @@ # provide the standard command set for ::xotcl2::Object foreach cmd [info command ::xotcl::cmd::Object::*] { set cmdName [namespace tail $cmd] - if {$cmdName in [list "instvar"]} continue + if {$cmdName in [list "instvar" "object-method"]} continue ::xotcl::alias Object $cmdName $cmd } @@ -28,7 +28,9 @@ # provide the standard command set for Class foreach cmd [info command ::xotcl::cmd::Class::*] { - ::xotcl::alias Class [namespace tail $cmd] $cmd + set cmdName [namespace tail $cmd] + if {$cmdName in [list "class-method"]} continue + ::xotcl::alias Class $cmdName $cmd } # set a few aliases as protected @@ -45,26 +47,65 @@ ::xotcl::methodproperty Class alloc static true ::xotcl::methodproperty Class dealloc static true ::xotcl::methodproperty Class create static true + + # TODO: both switches -protected and -public don't make much sense, + # but we allow it for the time being + # + # TODO: methodproperty is not necessary, when the base method + # supports all settings (e.g. -callprotection public|protected) + ::xotcl::dispatch Class ::xotcl::cmd::Class::class-method method { + -per-object:switch -public:switch -protected:switch + name arguments body -precondition -postcondition + } { + set conditions [list] + if {[info exists precondition]} {lappend conditions -precondition $precondition} + if {[info exists postcondition]} {lappend conditions -postcondition $postcondition} + if {${per-object}} { + set cls Object + set prefix object + } else { + set cls Class + set prefix class + } + ::xotcl::dispatch [self] ::xotcl::cmd::${cls}::$prefix-method \ + $name $arguments $body {*}$conditions + if {$protected} {::xotcl::methodproperty [self] $name protected true} + #puts stderr "[self] $name defined ($prefix-method)" + } + ::xotcl::dispatch Object ::xotcl::cmd::Class::class-method method { + -public:switch -protected:switch + name arguments body -precondition -postcondition + } { + set conditions [list] + if {[info exists precondition]} {lappend conditions -precondition $precondition} + if {[info exists postcondition]} {lappend conditions -postcondition $postcondition} + ::xotcl::dispatch [self] ::xotcl::cmd::Object::object-method \ + $name $arguments $body {*}$conditions + if {$protected} {::xotcl::methodproperty [self] $name -per-object protected true} + #puts stderr "[self] $name defined (object-method)" + } + Class method unknown {args} { puts stderr "use '[self] create $args', not '[self] $args'" eval my create $args } + Object method unknown {m args} { if {![self isnext]} { error "[self]: unable to dispatch method '$m'" } } # "init" must exist on Object. per default it is empty. - Object method init args {} + Object method -protected init args {} # this method is called on calls to object without a specified method Object method defaultmethod {} {::xotcl::self} # provide a placeholder for the bootup process. The real definition # is based on slots, which are not available at this point. - Object method objectparameter {} {;} + Object method -protected objectparameter {} {;} # The method __unknown is called in cases, where we try to resolve # an unkown class. one could define a custom resolver with this name @@ -262,7 +303,7 @@ return $parameterdefinitions } -::xotcl2::Object method objectparameter {} { +::xotcl2::Object method -protected objectparameter {} { set parameterdefinitions [::xotcl::parametersFromSlots [self]] if {[::xotcl::is [self] class]} { lappend parameterdefinitions -parameter:method,optional @@ -608,7 +649,7 @@ if {[.info callable -which assign] ne "::xotcl::Slot alias assign ::xotcl::setinstvar"} return if {[.info callable -which get] ne "::xotcl::Slot alias get ::xotcl::setinstvar"} return #puts stderr "**** optimizing ${.domain} $forwarder ${.name}" - ${.domain} setter {*}[expr {${.per-object} ? "-per-object" : ""}] ${.name} + ::xotcl::dispatch ${.domain} ::xotcl::cmd::Class::setter {*}[expr {${.per-object} ? "-per-object" : ""}] ${.name} } } # register the optimizer per default Index: generic/tclAPI.h =================================================================== diff -u -r04747ba752ca2b7a4f30586348e39ab04f190da9 -rbf9bae94d157de9bbd4c398f6a3a9a4d93626025 --- generic/tclAPI.h (.../tclAPI.h) (revision 04747ba752ca2b7a4f30586348e39ab04f190da9) +++ generic/tclAPI.h (.../tclAPI.h) (revision bf9bae94d157de9bbd4c398f6a3a9a4d93626025) @@ -193,7 +193,7 @@ static int XOTclCForwardMethod(Tcl_Interp *interp, XOTclClass *cl, int withPer_object, Tcl_Obj *name, Tcl_Obj *withDefault, int withEarlybinding, Tcl_Obj *withMethodprefix, int withObjscope, Tcl_Obj *withOnerror, int withVerbose, Tcl_Obj *target, int nobjc, Tcl_Obj *CONST nobjv[]); static int XOTclCInvalidateObjectParameterMethod(Tcl_Interp *interp, XOTclClass *cl); static int XOTclCInvariantsMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *invariantlist); -static int XOTclCMethodMethod(Tcl_Interp *interp, XOTclClass *cl, int withInner_namespace, int withPer_object, int withPublic, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition); +static int XOTclCMethodMethod(Tcl_Interp *interp, XOTclClass *cl, int withInner_namespace, int withPublic, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition); static int XOTclCMixinGuardMethod(Tcl_Interp *interp, XOTclClass *cl, int withPer_object, char *mixin, Tcl_Obj *guard); static int XOTclCNewMethod(Tcl_Interp *interp, XOTclClass *cl, XOTclObject *withChildof, int nobjc, Tcl_Obj *CONST nobjv[]); static int XOTclCRecreateMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *name, int objc, Tcl_Obj *CONST objv[]); @@ -556,16 +556,15 @@ return TCL_ERROR; } else { int withInner_namespace = (int )pc.clientData[0]; - int withPer_object = (int )pc.clientData[1]; - int withPublic = (int )pc.clientData[2]; - Tcl_Obj *name = (Tcl_Obj *)pc.clientData[3]; - Tcl_Obj *args = (Tcl_Obj *)pc.clientData[4]; - Tcl_Obj *body = (Tcl_Obj *)pc.clientData[5]; - Tcl_Obj *withPrecondition = (Tcl_Obj *)pc.clientData[6]; - Tcl_Obj *withPostcondition = (Tcl_Obj *)pc.clientData[7]; + int withPublic = (int )pc.clientData[1]; + Tcl_Obj *name = (Tcl_Obj *)pc.clientData[2]; + Tcl_Obj *args = (Tcl_Obj *)pc.clientData[3]; + Tcl_Obj *body = (Tcl_Obj *)pc.clientData[4]; + Tcl_Obj *withPrecondition = (Tcl_Obj *)pc.clientData[5]; + Tcl_Obj *withPostcondition = (Tcl_Obj *)pc.clientData[6]; parseContextRelease(&pc); - return XOTclCMethodMethod(interp, cl, withInner_namespace, withPer_object, withPublic, name, args, body, withPrecondition, withPostcondition); + return XOTclCMethodMethod(interp, cl, withInner_namespace, withPublic, name, args, body, withPrecondition, withPostcondition); } } @@ -2145,9 +2144,8 @@ {"::xotcl::cmd::Class::instinvar", XOTclCInvariantsMethodStub, 1, { {"invariantlist", 1, 0, convertToTclobj}} }, -{"::xotcl::cmd::Class::method", XOTclCMethodMethodStub, 8, { +{"::xotcl::cmd::Class::class-method", XOTclCMethodMethodStub, 7, { {"-inner-namespace", 0, 0, convertToBoolean}, - {"-per-object", 0, 0, convertToBoolean}, {"-public", 0, 0, convertToString}, {"name", 1, 0, convertToTclobj}, {"args", 1, 0, convertToTclobj}, @@ -2370,7 +2368,7 @@ {"::xotcl::cmd::Object::invar", XOTclOInvariantsMethodStub, 1, { {"invariantlist", 1, 0, convertToTclobj}} }, -{"::xotcl::cmd::Object::method", XOTclOMethodMethodStub, 7, { +{"::xotcl::cmd::Object::object-method", XOTclOMethodMethodStub, 7, { {"-inner-namespace", 0, 0, convertToString}, {"-public", 0, 0, convertToString}, {"name", 1, 0, convertToTclobj}, Index: generic/xotcl.c =================================================================== diff -u -r04747ba752ca2b7a4f30586348e39ab04f190da9 -rbf9bae94d157de9bbd4c398f6a3a9a4d93626025 --- generic/xotcl.c (.../xotcl.c) (revision 04747ba752ca2b7a4f30586348e39ab04f190da9) +++ generic/xotcl.c (.../xotcl.c) (revision bf9bae94d157de9bbd4c398f6a3a9a4d93626025) @@ -6383,9 +6383,11 @@ } ParamDefsStore(interp, (Tcl_Command)procPtr->cmdPtr, parsedParam.paramDefs); +#if 0 if (!withPublic) { Tcl_Command_flags((Tcl_Command)procPtr->cmdPtr) |= XOTCL_CMD_PROTECTED_METHOD; } +#endif } Tcl_PopCallFrame(interp); @@ -10019,7 +10021,7 @@ * vs. "info method search" vs. "info defined" etc. */ if (withCallprotection == CallprotectionNULL) { - withCallprotection = CallprotectionAllIdx; + withCallprotection = CallprotectionPublicIdx; } Tcl_InitHashTable(dups, TCL_STRING_KEYS); @@ -12464,19 +12466,13 @@ /* TODO move me at the right place */ static int XOTclCMethodMethod(Tcl_Interp *interp, XOTclClass *cl, - int withInner_namespace, int withPer_object, int withPublic, + int withInner_namespace, int withPublic, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition) { - if (withPer_object) { - requireObjNamespace(interp, &cl->object); - return MakeMethod(interp, &cl->object, NULL, name, args, body, + + return MakeMethod(interp, &cl->object, cl, name, args, body, withPrecondition, withPostcondition, withPublic, withInner_namespace); - } else { - return MakeMethod(interp, &cl->object, cl, name, args, body, - withPrecondition, withPostcondition, - withPublic, withInner_namespace); - } } static int XOTclCForwardMethod(Tcl_Interp *interp, XOTclClass *cl, Index: library/lib/xotcl1.xotcl =================================================================== diff -u -r04747ba752ca2b7a4f30586348e39ab04f190da9 -rbf9bae94d157de9bbd4c398f6a3a9a4d93626025 --- library/lib/xotcl1.xotcl (.../xotcl1.xotcl) (revision 04747ba752ca2b7a4f30586348e39ab04f190da9) +++ library/lib/xotcl1.xotcl (.../xotcl1.xotcl) (revision bf9bae94d157de9bbd4c398f6a3a9a4d93626025) @@ -13,7 +13,9 @@ # provide the standard command set for ::xotcl::Object foreach cmd [info command ::xotcl::cmd::Object::*] { - ::xotcl::alias Object [namespace tail $cmd] $cmd + set cmdName [namespace tail $cmd] + if {$cmdName in [list "setter" "object-method"]} continue + ::xotcl::alias Object $cmdName $cmd } # provide some Tcl-commands as methods for ::xotcl::Object @@ -23,7 +25,9 @@ # provide the standard command set for ::xotcl::Class foreach cmd [info command ::xotcl::cmd::Class::*] { - ::xotcl::alias Class [namespace tail $cmd] $cmd + set cmdName [namespace tail $cmd] + if {$cmdName in [list "setter" "class-method"]} continue + ::xotcl::alias Class $cmdName $cmd } # protect some methods against redefinition @@ -32,26 +36,59 @@ ::xotcl::methodproperty Class dealloc static true ::xotcl::methodproperty Class create static true - Class method -public unknown {args} { + # define instproc and proc + ::xotcl::dispatch Class ::xotcl::cmd::Class::class-method instproc { + name arguments body precondition:optional postcondition:optional + } { + set conditions [list] + if {[info exists precondition]} {lappend conditions -precondition $precondition} + if {[info exists postcondition]} {lappend conditions -postcondition $postcondition} + ::xotcl::dispatch [self] ::xotcl::cmd::Class::class-method $name $arguments $body {*}$conditions + #puts stderr "[self] [self proc] $name defined" + } + + ::xotcl::dispatch Object ::xotcl::cmd::Class::class-method proc { + name arguments body precondition:optional postcondition:optional + } { + set conditions [list] + if {[info exists precondition]} {lappend conditions -precondition $precondition} + if {[info exists postcondition]} {lappend conditions -postcondition $postcondition} + ::xotcl::dispatch [self] ::xotcl::cmd::Object::object-method $name $arguments $body {*}$conditions + #puts stderr "[self] [self proc] $name defined" + } + + # define - like in xotcl - a minimal implementation of "method" + Object instproc method {name arguments body} { + .proc $name $arguments $body + } + Class instproc method {-per-object:switch name arguments body} { + if {${per-object}} { + .proc $name $arguments $body + } else { + .instproc $name $arguments $body + } + } + + Class instproc unknown {args} { #puts stderr "use '[self] create $args', not '[self] $args'" eval my create $args } - Object method -public unknown {m args} { + Object instproc unknown {m args} { if {![self isnext]} { error "[self]: unable to dispatch method '$m'" } } # "init" must exist on Object. per default it is empty. - Object method -public init args {} + Object instproc init args {} - Object method -public self {} {::xotcl::self} + Object instproc self {} {::xotcl::self} # # object-parameter definition, backwards compatible # - ::xotcl::Object method objectparameter {} { + ::xotcl::Object instproc objectparameter {} { set parameterdefinitions [::xotcl::parametersFromSlots [self]] lappend parameterdefinitions args #puts stderr "*** parameter definition for [self]: $parameterdefinitions" @@ -121,7 +158,7 @@ Object forward info -onerror ::xotcl::infoError ::xotcl::objectInfo %1 {%@2 %self} Class forward info -onerror ::xotcl::infoError ::xotcl::classInfo %1 {%@2 %self} - objectInfo method -public info {obj} { + objectInfo proc info {obj} { set methods [list] foreach m [::info commands ::xotcl::objectInfo::*] { set name [namespace tail $m] @@ -130,11 +167,11 @@ } return "valid options are: [join [lsort $methods] {, }]" } - objectInfo method unknown {method args} { + objectInfo proc unknown {method args} { error "[::xotcl::self] unknown info option \"$method\"; [.info info]" } - classInfo method -public info {cl} { + classInfo proc info {cl} { set methods [list] foreach m [::info commands ::xotcl::classInfo::*] { set name [namespace tail $m] @@ -143,7 +180,8 @@ } return "valid options are: [join [lsort $methods] {, }]" } - classInfo method unknown {method args} { + + classInfo proc unknown {method args} { error "[::xotcl::self] unknown info option \"$method\"; [.info info]" } @@ -237,55 +275,55 @@ error "procedure \"$method\" doesn't have an argument \"$varName\"" } classInfo eval { - .method -public instargs {o method} {::xotcl::info_args Class $o $method} - .method -public args {o method} {::xotcl::info_args Object $o $method} - .method -public instnonposargs {o method} {::xotcl::info_nonposargs Class $o $method} - .method -public nonposargs {o method} {::xotcl::info_nonposargs Object $o $method} - .method -public instdefault {o method arg var} {::xotcl::info_default Class $o $method $arg $var} - .method -public default {o method arg var} {::xotcl::info_default Object $o $method $arg $var} + .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} # info options emulated by "info method" - .method -public instbody {o methodName} { + .proc instbody {o methodName} { lindex [::xotcl::cmd::ClassInfo::method $o definition $methodName] end } - .method -public instpre {o methodName} {::xotcl::cmd::ClassInfo::method $o precondition $methodName} - .method -public instpost {o methodName} {::xotcl::cmd::ClassInfo::method $o postcondition $methodName} + .proc instpre {o methodName} {::xotcl::cmd::ClassInfo::method $o precondition $methodName} + .proc instpost {o methodName} {::xotcl::cmd::ClassInfo::method $o postcondition $methodName} # info options emulated by "info methods" - .method -public instcommands {o {pattern:optional ""}} { + .proc instcommands {o {pattern:optional ""}} { ::xotcl::cmd::ClassInfo::methods $o {*}$pattern } - .method -public instprocs {o {pattern:optional ""}} { + .proc instprocs {o {pattern:optional ""}} { ::xotcl::cmd::ClassInfo::methods $o -methodtype scripted {*}$pattern } - .method -public parametercmd {o {pattern:optional ""}} { + .proc parametercmd {o {pattern:optional ""}} { ::xotcl::cmd::ClassInfo::methods $o -per-object -methodtype setter {*}$pattern } - .method -public instparametercmd {o {pattern:optional ""}} { + .proc instparametercmd {o {pattern:optional ""}} { ::xotcl::cmd::ClassInfo::methods $o -methodtype setter {*}$pattern } } objectInfo eval { - .method -public args {o method} {::xotcl::info_args Object $o $method} - .method -public nonposargs {o method} {::xotcl::info_nonposargs Object $o $method} - .method -public default {o method arg var} {::xotcl::info_default Object $o $method $arg $var} + .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" - .method -public body {o methodName} { + .proc body {o methodName} { lindex [::xotcl::cmd::ObjectInfo::method $o definition $methodName] end } - .method -public pre {o methodName} {::xotcl::cmd::ObjectInfo::method $o pre $methodName} - .method -public post {o methodName} {::xotcl::cmd::ObjectInfo::method $o post $methodName} + .proc pre {o methodName} {::xotcl::cmd::ObjectInfo::method $o pre $methodName} + .proc post {o methodName} {::xotcl::cmd::ObjectInfo::method $o post $methodName} # info options emulated by "info methods" - .method -public commands {o {pattern:optional ""}} { + .proc commands {o {pattern:optional ""}} { ::xotcl::cmd::ObjectInfo::methods $o {*}$pattern } - .method -public procs {o {pattern:optional ""}} { + .proc procs {o {pattern:optional ""}} { ::xotcl::cmd::ObjectInfo::methods $o -methodtype scripted {*}$pattern } - .method -public methods { + .proc methods { o -nocmds:switch -noprocs:switch -incontext:switch pattern:optional } { set methodtype all @@ -332,42 +370,23 @@ # emulation of isobject, isclass ... - Object method -public isobject {{object:substdefault "[self]"}} {::xotcl::is $object object} - Object method -public isclass {{class:substdefault "[self]"}} {::xotcl::is $class class} - Object method -public ismetaclass {{class:substdefault "[self]"}} {::xotcl::is $class metaclass} - Object method -public ismixin {class} {::xotcl::is [self] mixin $class} - Object method -public istype {class} {::xotcl::is [self] type $class} + Object instproc isobject {{object:substdefault "[self]"}} {::xotcl::is $object object} + Object instproc isclass {{class:substdefault "[self]"}} {::xotcl::is $class class} + Object instproc ismetaclass {{class:substdefault "[self]"}} {::xotcl::is $class metaclass} + Object instproc ismixin {class} {::xotcl::is [self] mixin $class} + Object instproc istype {class} {::xotcl::is [self] type $class} - ::xotcl::alias ::xotcl::Object contains ::xotcl::classes::xotcl2::Object::contains + ::xotcl::alias Object parametercmd ::xotcl::cmd::Object::setter + ::xotcl::alias Object contains ::xotcl::classes::xotcl2::Object::contains + ::xotcl::Class forward slots %self contains \ -object {%::xotcl::dispatch [::xotcl::self] -objscope ::subst [::xotcl::self]::slot} # - # define proc and instproc in terms of method # define forward and instforward in terms of forward # define parametercmd and instparametercmd in terms of setter # define parametercmd and instparametercmd in terms of setter # define mixinguard and instmixinguard in terms of mixinguard # - Object method -public proc {name arglist body precondition:optional postcondition:optional} { - set cmd [list my method -public $name $arglist $body] - if {[info exists precondition]} {lappend cmd -precondition $precondition} - if {[info exists postcondition]} {lappend cmd -postcondition $postcondition} - eval $cmd - } - ::xotcl::alias Object parametercmd ::xotcl::cmd::Object::setter - - Class method -public proc {name arglist body precondition:optional postcondition:optional} { - set cmd [list my method -public -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 -public instproc {name arglist body precondition:optional postcondition:optional} { - set cmd [list my method -public $name $arglist $body] - if {[info exists precondition]} {lappend cmd -precondition $precondition} - if {[info exists postcondition]} {lappend cmd -postcondition $postcondition} - eval $cmd - } ::xotcl::alias Class instparametercmd ::xotcl::cmd::Class::setter ::xotcl::alias Class parametercmd ::xotcl::cmd::Object::setter ::xotcl::alias Class filterguard ::xotcl::cmd::Object::filterguard @@ -382,7 +401,7 @@ ::xotcl::alias Class instforward ::xotcl::cmd::Class::forward ::xotcl::alias Class forward ::xotcl::cmd::Object::forward - Object method -public abstract {methtype methname arglist} { + Object instproc abstract {methtype methname arglist} { if {$methtype ne "proc" && $methtype ne "instproc" && $methtype ne "method"} { error "invalid method type '$methtype', \ must be either 'proc', 'instproc' or 'method'." @@ -395,11 +414,11 @@ } # support for XOTcl 1.* specific convenience routines - Object method -public hasclass cl { + Object instproc hasclass cl { if {[::xotcl::is [self] mixin $cl]} {return 1} ::xotcl::is [self] type $cl } - Object method -public procsearch {name} { + Object instproc procsearch {name} { set definition [::xotcl::cmd::ObjectInfo::callable [self] -which $name] if {$definition ne ""} { foreach {obj kind arg} $definition break @@ -416,15 +435,15 @@ return [list $obj $kind $name] } } - Class method -public allinstances {} { + Class instproc allinstances {} { # TODO: mark it deprecated return [.info instances -closure] } # keep old object interface for xotcl 1.* - Object method -public -per-object unsetExitHandler {} {::xotcl::unsetExitHandler $newbody} - Object method -public -per-object setExitHandler {newbody} {::xotcl::setExitHandler $newbody} - Object method -public -per-object getExitHandler {} {:xotcl::getExitHandler} + Object proc unsetExitHandler {} {::xotcl::unsetExitHandler $newbody} + Object proc setExitHandler {newbody} {::xotcl::setExitHandler $newbody} + Object proc getExitHandler {} {:xotcl::getExitHandler} # resue some definitions from ::xotcl2 ::xotcl::alias ::xotcl::Object copy ::xotcl::classes::xotcl2::Object::copy @@ -438,7 +457,7 @@ proc myvar {var} {.requireNamespace; return [::xotcl::self]::$var} Object create ::xotcl::config - config method -public load {obj file} { + config proc load {obj file} { source $file foreach i [array names ::auto_index [list $obj *proc *]] { set type [lindex $i 1] @@ -449,7 +468,7 @@ } } - config method -public mkindex {meta dir args} { + config proc mkindex {meta dir args} { set sp {[ ]+} set st {^[ ]*} set wd {([^ ;]+)} @@ -516,7 +535,7 @@ # # if cutTheArg not 0, it cut from upvar argsList # - Object method -public extractConfigureArg {al name {cutTheArg 0}} { + Object instproc extractConfigureArg {al name {cutTheArg 0}} { set value "" upvar $al argList set largs [llength $argList] @@ -538,10 +557,10 @@ } Object create ::xotcl::rcs - rcs method -public date string { + rcs proc date string { lreplace [lreplace $string 0 0] end end } - rcs method -public version string { + rcs proc version string { lindex $string 2 } @@ -550,7 +569,7 @@ # # puts this for the time being into xotcl 1.* # - ::xotcl::Class method -public uses list { + ::xotcl::Class instproc uses list { foreach package $list { ::xotcl::package import -into [::xotcl::self] $package puts stderr "*** using ${package}::* in [::xotcl::self]" Index: tests/info-method.xotcl =================================================================== diff -u -r04747ba752ca2b7a4f30586348e39ab04f190da9 -rbf9bae94d157de9bbd4c398f6a3a9a4d93626025 --- tests/info-method.xotcl (.../info-method.xotcl) (revision 04747ba752ca2b7a4f30586348e39ab04f190da9) +++ tests/info-method.xotcl (.../info-method.xotcl) (revision bf9bae94d157de9bbd4c398f6a3a9a4d93626025) @@ -36,7 +36,7 @@ C create c1 ? {lsort [C info methods -callprotection all]} "a addOne m m-with-assertions s" -? {lsort [C info methods]} "a addOne s" +#? {lsort [C info methods]} "a addOne s" foreach m [lsort [C info methods -callprotection all]] { ? [subst -nocommands {lsort [c1 info callable $m]}] $m } @@ -59,7 +59,7 @@ {::C method m-with-assertions {} {return proc-[self proc]} -precondition 1 -postcondition 2} ? {C info method parameter m} {x} ? {Class info method parameter method} \ - {-inner-namespace -per-object -protected name args body -precondition -postcondition} + {{-per-object:switch 0} {-public:switch 0} {-protected:switch 0} name arguments body -precondition -postcondition} ? {Object info method parameter alias} \ {{-objscope:switch 0} {-protected:switch 0} methodName cmd} # raises currently an error Index: tests/slottest.xotcl =================================================================== diff -u -r477c12e1b0f192ab18de415e30001ea151d7ddda -rbf9bae94d157de9bbd4c398f6a3a9a4d93626025 --- tests/slottest.xotcl (.../slottest.xotcl) (revision 477c12e1b0f192ab18de415e30001ea151d7ddda) +++ tests/slottest.xotcl (.../slottest.xotcl) (revision bf9bae94d157de9bbd4c398f6a3a9a4d93626025) @@ -327,10 +327,10 @@ ? {a0 procsearch f3} "::a0 proc f3" ? {a0 procsearch f4} "::a0 forward f4" ? {a0 procsearch set} "::xotcl::Object instcmd set" -? {A slot foo procsearch assign} "::xotcl::Slot instcmd assign" +? {A slot foo info callable -which assign} "::xotcl::Slot alias assign ::xotcl::setinstvar" # redefine setter for foo of class A -A slot foo proc assign {domain var val} { +A slot foo method assign {domain var val} { # Do something with [self] that isn't valid pre-init puts setter-[self proc] $domain set $var $val Index: tests/testx.xotcl =================================================================== diff -u -r1f0231a5c7cbb8dfef4eaf78335c9ad571863660 -rbf9bae94d157de9bbd4c398f6a3a9a4d93626025 --- tests/testx.xotcl (.../testx.xotcl) (revision 1f0231a5c7cbb8dfef4eaf78335c9ad571863660) +++ tests/testx.xotcl (.../testx.xotcl) (revision bf9bae94d157de9bbd4c398f6a3a9a4d93626025) @@ -386,7 +386,7 @@ SC($i) destroy } - ::errorCheck $::filterCount 1120 \ + ::errorCheck $::filterCount 1080 \ "Filter Test - Filter Count -- Got: $::filterCount" # @@ -3101,15 +3101,15 @@ ::errorCheck [b info procs] objproc "info procs" ::errorCheck [B info instprocs] myProc2 "info instprocs" - ::errorCheck [lsort [b info methods]] "__next abstract append array autoname check class cleanup configure contains copy defaultmethod destroy eval exists extractConfigureArg f filter filterguard filtersearch forward hasclass incr info init instvar invar isclass ismetaclass ismixin isobject istype lappend method mixin mixinguard move myProc myProc2 myProcMix1 myProcMix2 noinit objectparameter objproc parametercmd proc procsearch requireNamespace residualargs self set setFilter setter signature subst trace unknown unset uplevel upvar volatile vwait" "b info methods" + ::errorCheck [lsort [b info methods]] "__next abstract append array autoname check class cleanup configure contains copy defaultmethod destroy eval exists extractConfigureArg f filter filterguard filtersearch forward hasclass incr info init instvar invar isclass ismetaclass ismixin isobject istype lappend method mixin mixinguard move myProc myProc2 myProcMix1 myProcMix2 noinit objectparameter objproc parametercmd proc procsearch requireNamespace residualargs self set setFilter signature subst trace unknown unset uplevel upvar volatile vwait" "b info methods" - ::errorCheck [lsort [b info methods -nocmds]] "abstract contains copy defaultmethod extractConfigureArg f hasclass init isclass ismetaclass ismixin isobject istype move myProc myProc2 myProcMix1 myProcMix2 objectparameter objproc proc procsearch self setFilter signature unknown" "b info methods -nocmds" + ::errorCheck [lsort [b info methods -nocmds]] "abstract contains copy defaultmethod extractConfigureArg f hasclass init isclass ismetaclass ismixin isobject istype method move myProc myProc2 myProcMix1 myProcMix2 objectparameter objproc proc procsearch self setFilter signature unknown" "b info methods -nocmds" - ::errorCheck [lsort [b info methods -noprocs]] "__next append array autoname check class cleanup configure destroy eval exists filter filterguard filtersearch forward incr info instvar invar lappend method mixin mixinguard noinit parametercmd requireNamespace residualargs set setter subst trace unset uplevel upvar volatile vwait" "b info methods -noprocs" - ::errorCheck [lsort [b info methods -nocmds -nomixins]] "abstract contains copy defaultmethod extractConfigureArg f hasclass init isclass ismetaclass ismixin isobject istype move myProc myProc2 objectparameter objproc proc procsearch self setFilter signature unknown" "b info methods -nocmds -nomixins" + ::errorCheck [lsort [b info methods -noprocs]] "__next append array autoname check class cleanup configure destroy eval exists filter filterguard filtersearch forward incr info instvar invar lappend mixin mixinguard noinit parametercmd requireNamespace residualargs set subst trace unset uplevel upvar volatile vwait" "b info methods -noprocs" + ::errorCheck [lsort [b info methods -nocmds -nomixins]] "abstract contains copy defaultmethod extractConfigureArg f hasclass init isclass ismetaclass ismixin isobject istype method move myProc myProc2 objectparameter objproc proc procsearch self setFilter signature unknown" "b info methods -nocmds -nomixins" ::errorCheck [b info methods -nocmds -noprocs] "" "b info methods -nocmds -noprocs" - ::errorCheck [lsort [B info methods -nocmds]] "abstract allinstances contains copy defaultmethod extractConfigureArg f hasclass init instproc isclass ismetaclass ismixin isobject istype move objectparameter parameter proc procsearch self setFilter signature unknown uses" "B info methods -nocmds" + ::errorCheck [lsort [B info methods -nocmds]] "abstract allinstances contains copy defaultmethod extractConfigureArg f hasclass init instproc isclass ismetaclass ismixin isobject istype method move objectparameter parameter proc procsearch self setFilter signature unknown uses" "B info methods -nocmds" namespace eval a { proc o args {return o} @@ -3500,9 +3500,9 @@ set ::context payrollApp - ::errorCheck [lsort [jim info methods]] "__next abstract age append array autoname check class cleanup configure contains copy defaultmethod destroy driving-license eval exists extractConfigureArg filter filterguard filtersearch forward hasclass id incr info init instvar invar isclass ismetaclass ismixin isobject istype lappend method mixin mixinguard move name noinit objectparameter parametercmd print proc procsearch requireNamespace residualargs salary self set setter signature subst trace unknown unset uplevel upvar volatile vwait" "condmixin all methods" + ::errorCheck [lsort [jim info methods]] "__next abstract age append array autoname check class cleanup configure contains copy defaultmethod destroy driving-license eval exists extractConfigureArg filter filterguard filtersearch forward hasclass id incr info init instvar invar isclass ismetaclass ismixin isobject istype lappend method mixin mixinguard move name noinit objectparameter parametercmd print proc procsearch requireNamespace residualargs salary self set signature subst trace unknown unset uplevel upvar volatile vwait" "condmixin all methods" - ::errorCheck "[lsort [jim info methods -incontext]]" "__next abstract age append array autoname check class cleanup configure contains copy defaultmethod destroy eval exists extractConfigureArg filter filterguard filtersearch forward hasclass id incr info init instvar invar isclass ismetaclass ismixin isobject istype lappend method mixin mixinguard move name noinit objectparameter parametercmd print proc procsearch requireNamespace residualargs salary self set setter signature subst trace unknown unset uplevel upvar volatile vwait" "all methods in context" + ::errorCheck "[lsort [jim info methods -incontext]]" "__next abstract age append array autoname check class cleanup configure contains copy defaultmethod destroy eval exists extractConfigureArg filter filterguard filtersearch forward hasclass id incr info init instvar invar isclass ismetaclass ismixin isobject istype lappend method mixin mixinguard move name noinit objectparameter parametercmd print proc procsearch requireNamespace residualargs salary self set signature subst trace unknown unset uplevel upvar volatile vwait" "all methods in context" ::errorCheck [my show payrollApp jim] "{payrollApp: jim info methods salary => salary} {payrollApp: jim info methods -incontext salary => salary} {payrollApp: jim info methods driv* => driving-license} {payrollApp: jim info methods -incontext driv* => }" "payrollApp jim" ::errorCheck [my show shipmentApp jim] "{shipmentApp: jim info methods salary => salary} {shipmentApp: jim info methods -incontext salary => } {shipmentApp: jim info methods driv* => driving-license} {shipmentApp: jim info methods -incontext driv* => driving-license}" "shipmentApp jim"