Index: Makefile.in =================================================================== diff -u -r9f7fa883bf6ed48f1401f815caca1e34f56584a1 -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 --- Makefile.in (.../Makefile.in) (revision 9f7fa883bf6ed48f1401f815caca1e34f56584a1) +++ Makefile.in (.../Makefile.in) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) @@ -342,28 +342,18 @@ #TESTFLAGS = -srcdir $(srcdir) test-core: $(TCLSH_PROG) - $(TCLSH) $(src_test_dir_native)/object-system.xotcl \ - -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/destroytest.xotcl \ - -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/aliastest.xotcl \ - -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/protected.xotcl \ - -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/testx.xotcl \ - -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/testo.xotcl \ - -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/speedtest.xotcl \ - -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/forwardtest.xotcl \ - -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/mixinoftest.xotcl \ - -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/varresolutiontest.xotcl \ - -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/slottest.xotcl \ - -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/object-system.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/destroytest.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/info-method.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/aliastest.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/protected.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/testx.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/testo.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/speedtest.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/forwardtest.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/mixinoftest.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/varresolutiontest.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/slottest.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) test-http: $(TCLSH_PROG) Index: doc/index.html =================================================================== diff -u -r9f7fa883bf6ed48f1401f815caca1e34f56584a1 -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 --- doc/index.html (.../index.html) (revision 9f7fa883bf6ed48f1401f815caca1e34f56584a1) +++ doc/index.html (.../index.html) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) @@ -23,7 +23,7 @@

Index: generic/gentclAPI.decls =================================================================== diff -u -rdb7c710aa3b6386c33af9a318876f21a88b8aafd -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision db7c710aa3b6386c33af9a318876f21a88b8aafd) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) @@ -160,9 +160,6 @@ } objectMethod noinit XOTclONoinitMethod { } -objectMethod parametercmd XOTclOParametercmdMethod { - {-argName "name" -required 1} -} objectMethod procsearch XOTclOProcSearchMethod { {-argName "name" -required 1} } @@ -171,6 +168,9 @@ objectMethod residualargs XOTclOResidualargsMethod { {-argName "args" -type allargs} } +objectMethod setter XOTclOSetterMethod { + {-argName "name" -required 1} +} objectMethod uplevel XOTclOUplevelMethod { {-argName "args" -type allargs} } @@ -211,9 +211,6 @@ {-argName "mixin" -required 1} {-argName "guard" -required 1 -type tclobj} } -classMethod instparametercmd XOTclCInstParametercmdMethod { - {-argName "name" -required 1} -} classMethod method XOTclCMethodMethod { {-argName "-inner-namespace" -type switch} {-argName "-per-object" -type switch} @@ -224,7 +221,8 @@ {-argName "-precondition" -nrargs 1 -type tclobj} {-argName "-postcondition" -nrargs 1 -type tclobj} } -classMethod instforward XOTclCInstForwardMethod { +classMethod forward XOTclCForwardMethod { + {-argName "-per-object" -type switch} {-argName "name" -required 1 -type tclobj} {-argName "-default" -nrargs 1 -type tclobj} {-argName "-earlybinding"} @@ -242,7 +240,10 @@ {-argName "name" -required 1 -type tclobj} {-argName "args" -type allargs} } - +classMethod setter XOTclCSetterMethod { + {-argName "-per-object" -type switch} + {-argName "name" -required 1} +} # # check methods # @@ -263,10 +264,6 @@ {-argName "-definition"} {-argName "name"} } -infoObjectMethod body XOTclObjInfoBodyMethod { - {-argName "object" -required 1 -type object} - {-argName "methodName" -required 1} -} infoObjectMethod check XOTclObjInfoCheckMethod { {-argName "object" -required 1 -type object} } @@ -277,10 +274,6 @@ infoObjectMethod class XOTclObjInfoClassMethod { {-argName "object" -required 1 -type object} } -infoObjectMethod commands XOTclObjInfoCommandsMethod { - {-argName "object" -required 1 -type object} - {-argName "pattern" -required 0} -} infoObjectMethod filter XOTclObjInfoFilterMethod { {-argName "object" -required 1 -type object} {-argName "-order"} @@ -302,6 +295,14 @@ infoObjectMethod invar XOTclObjInfoInvarMethod { {-argName "object" -required 1 -type object} } +#### TODO should object methods have -per-object? +infoObjectMethod method XOTclObjInfoMethodMethod { + {-argName "object" -required 1 -type object} + {-argName "-per-object"} + {-argName "infomethodsubcmd" -type "definition|name|type"} + {-argName "name"} +} +### TODO should object methods have -per-object? infoObjectMethod methods XOTclObjInfoMethodsMethod { {-argName "object" -required 1 -type object} {-argName "-defined"} @@ -329,10 +330,6 @@ {-argName "methodName" -required 1} {-argName "-varNames"} } -infoObjectMethod parametercmd XOTclObjInfoParametercmdMethod { - {-argName "object" -required 1 -type object} - {-argName "pattern"} -} infoObjectMethod post XOTclObjInfoPostMethod { {-argName "object" -required 1 -type object} {-argName "methodName" -required 1} @@ -374,14 +371,6 @@ {-argName "-closure"} {-argName "pattern" -type objpattern} } -infoClassMethod instbody XOTclClassInfoInstbodyMethod { - {-argName "class" -required 1 -type class} - {-argName "methodName" -required 1} -} -infoClassMethod instcommands XOTclClassInfoInstcommandsMethod { - {-argName "class" -required 1 -type class} - {-argName "pattern"} -} infoClassMethod instfilter XOTclClassInfoInstfilterMethod { {-argName "class" -required 1 -type class} {-argName "-guards"} @@ -414,10 +403,6 @@ {-argName "-closure"} {-argName "pattern" -type objpattern} } -infoClassMethod instparametercmd XOTclClassInfoInstparametercmdMethod { - {-argName "class" -required 1 -type class} - {-argName "pattern"} -} infoClassMethod instparams XOTclClassInfoInstparamsMethod { {-argName "class" -required 1 -type class} {-argName "methodName" -required 1} Index: generic/gentclAPI.tcl =================================================================== diff -u -re767edf5c498094f6e00150541bfb7beab52b619 -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 --- generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision e767edf5c498094f6e00150541bfb7beab52b619) +++ generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) @@ -264,7 +264,7 @@ char *methodName; Tcl_ObjCmdProc *proc; int nrParameters; - XOTclParam paramDefs[10]; + XOTclParam paramDefs[11]; } methodDefinition; static int ArgumentParse(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], Index: generic/predefined.h =================================================================== diff -u -rdb7c710aa3b6386c33af9a318876f21a88b8aafd -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 --- generic/predefined.h (.../predefined.h) (revision db7c710aa3b6386c33af9a318876f21a88b8aafd) +++ generic/predefined.h (.../predefined.h) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) @@ -22,22 +22,12 @@ "Object method defaultmethod {} {::xotcl::self}\n" "Object method objectparameter {} {;}\n" "Class method -per-object __unknown {name} {}\n" -"Object method alias {-per-object:switch methodName -cmd -source-object -source-method -source-per-object:switch} {\n" -"if {[info exists cmd]} {\n" -"set cmd [namespace origin $cmd]} elseif {[info exists source-method]} {\n" -"if {![info exists source-object]} {\n" -"set source-object [self]} else {\n" -"set source-object [::xotcl::dispatch ${source-object} -objscope ::xotcl::self]}\n" -"if {${source-per-object}} {\n" -"set cmd ${source-object}::$methodName} else {\n" -"set cmd ::xotcl::classes${source-object}::${source-method}}}\n" -"if {${per-object} && [::xotcl::is [self] class]} {\n" -"eval ::xotcl::alias [self] $methodName -per-object $cmd} else {\n" -"eval ::xotcl::alias [self] $methodName $cmd}}\n" +"Object method alias {-per-object:switch methodName cmd} {\n" +"::xotcl::alias [self] $methodName {*}[expr {${per-object} ? \"-per-object\" : \"\"}] $cmd}\n" "Object create ::xotcl2::objectInfo\n" "Object create ::xotcl2::classInfo\n" "::xotcl::dispatch objectInfo -objscope ::eval {\n" -".alias is -cmd ::xotcl::is\n" +".alias is ::xotcl::is\n" ".method info {obj} {\n" "set methods [list]\n" "foreach name [::xotcl::cmd::ObjectInfo::methods [self] -defined] {\n" @@ -47,19 +37,19 @@ ".method unknown {method obj args} {\n" "error \"[::xotcl::self] unknown info option \\\"$method\\\"; [$obj info info]\"}}\n" "::xotcl::dispatch classInfo -objscope ::eval {\n" -".alias is -cmd ::xotcl::is\n" -".alias classparent -cmd ::xotcl::cmd::ObjectInfo::parent\n" -".alias classchildren -cmd ::xotcl::cmd::ObjectInfo::children\n" -".alias info -source-object objectInfo -source-per-object -source-method info\n" -".alias unknown -source-object objectInfo -source-per-object -source-method unknown}\n" +".alias is ::xotcl::is\n" +".alias classparent ::xotcl::cmd::ObjectInfo::parent\n" +".alias classchildren ::xotcl::cmd::ObjectInfo::children\n" +".alias info [::xotcl::cmd::ObjectInfo::method objectInfo -per-object name info]\n" +".alias unknown [::xotcl::cmd::ObjectInfo::method objectInfo -per-object name info]}\n" "foreach cmd [info command ::xotcl::cmd::ObjectInfo::*] {\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 ::xotcl2::classInfo [namespace tail $cmd] $cmd}\n" "unset cmd\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" +"Object forward info -onerror ::xotcl::infoError ::xotcl2::objectInfo %1 {%@2 %self}\n" +"Class forward 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" @@ -131,7 +121,7 @@ "if {[info exists default]} {\n" "::xotcl::setinstvar ${class}::slot::$att default $default\n" "unset default}\n" -"$class instparametercmd $att}\n" +"$class setter $att}\n" "foreach att $definitions {\n" "if {[llength $att]>1} {foreach {att default} $att break}\n" "if {[info exists default]} {\n" @@ -177,12 +167,13 @@ "${.domain} invalidateobjectparameter}\n" "next}\n" "::xotcl::Slot method init {args} {\n" -"set forwarder [expr {${.per-object} ? \"forward\" : \"instforward\"}]\n" "if {${.domain} eq \"\"} {\n" "set .domain [::xotcl::self callingobject]}\n" "if {${.domain} ne \"\"} {\n" "${.domain} invalidateobjectparameter\n" -"${.domain} $forwarder ${.name} -default [${.manager} defaultmethods] ${.manager} %1 %self %proc}}\n" +"::xotcl::dispatch ${.domain} ::xotcl::cmd::Class::forward \\\n" +"{*}[expr {${.per-object} ? \"-per-object\" : \"\"}] ${.name} \\\n" +"-default [${.manager} defaultmethods] ${.manager} %1 %self %proc}}\n" "::xotcl::MetaSlot create ::xotcl::InfoSlot\n" "createBootstrapAttributeSlots ::xotcl::InfoSlot {\n" "{multivalued true}\n" @@ -299,8 +290,7 @@ "if {[set .defaultmethods] ne {get assign}} return\n" "if {[.procsearch assign] ne \"::xotcl::Slot instcmd assign\"} return\n" "if {[.procsearch get] ne \"::xotcl::Slot instcmd get\"} return\n" -"set forwarder [expr {[set .per-object] ? \"parametercmd\":\"instparametercmd\"}]\n" -"${.domain} $forwarder ${.name}}}\n" +"${.domain} setter {*}[expr {${.per-object} ? \"-per-object\" : \"\"}] ${.name}}}\n" "::xotcl::Attribute instmixin add ::xotcl::Slot::Optimizer\n" "::xotcl2::Class create ::xotcl::ScopedNew -superclass ::xotcl2::Class\n" "createBootstrapAttributeSlots ::xotcl::ScopedNew {\n" @@ -327,7 +317,7 @@ "namespace eval $object $cmds\n" "::xotcl2::Class instmixin delete $m} else {\n" "namespace eval $object $cmds}}\n" -"::xotcl2::Class instforward slots %self contains \\\n" +"::xotcl2::Class forward slots %self contains \\\n" "-object {%::xotcl::dispatch [::xotcl::self] -objscope ::subst [::xotcl::self]::slot}\n" "::xotcl2::Class method parameter arglist {\n" "if {![::xotcl::is [::xotcl::self]::slot object]} {\n" @@ -378,7 +368,7 @@ "return \\[eval $access $setter $extra $name \\$args $defaultParam \\]}\"\n" "foreach instvar {extra defaultParam setter getter access} {\n" "$po unset -nocomplain $instvar}} else {\n" -".instparametercmd $name}}}\n" +".setter $name}}}\n" "::xotcl::setinstvar [::xotcl::self]::slot __parameter $arglist}\n" "::xotcl2::Class create ::xotcl::CopyHandler -parameter {\n" "{targetList \"\"}\n" Index: generic/predefined.xotcl =================================================================== diff -u -rdb7c710aa3b6386c33af9a318876f21a88b8aafd -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 --- generic/predefined.xotcl (.../predefined.xotcl) (revision db7c710aa3b6386c33af9a318876f21a88b8aafd) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) @@ -63,31 +63,13 @@ Class method -per-object __unknown {name} { } - # - # TODO: ::xotcl::alias has -per-object after methodName, "method" before it (because auf arguments) - # - Object method alias {-per-object:switch methodName -cmd -source-object -source-method -source-per-object:switch} { - if {[info exists cmd]} { - set cmd [namespace origin $cmd] - } elseif {[info exists source-method]} { - if {![info exists source-object]} { - set source-object [self] - } else { - set source-object [::xotcl::dispatch ${source-object} -objscope ::xotcl::self] - } - if {${source-per-object}} { - set cmd ${source-object}::$methodName - } else { - set cmd ::xotcl::classes${source-object}::${source-method} - } - } - if {${per-object} && [::xotcl::is [self] class]} { - eval ::xotcl::alias [self] $methodName -per-object $cmd - } else { - eval ::xotcl::alias [self] $methodName $cmd - } + # Add an alias method. cmdName for XOTcl method can be added via + # [... info method name ] + Object method alias {-per-object:switch methodName cmd} { + ::xotcl::alias [self] $methodName {*}[expr {${per-object} ? "-per-object" : ""}] $cmd } + ######################## # Info definition ######################## @@ -99,7 +81,7 @@ # we have no working objectparameter yet due to bootstrapping # ::xotcl::dispatch objectInfo -objscope ::eval { - .alias is -cmd ::xotcl::is + .alias is ::xotcl::is .method info {obj} { set methods [list] @@ -113,14 +95,15 @@ .method unknown {method obj args} { error "[::xotcl::self] unknown info option \"$method\"; [$obj info info]" } + } ::xotcl::dispatch classInfo -objscope ::eval { - .alias is -cmd ::xotcl::is - .alias classparent -cmd ::xotcl::cmd::ObjectInfo::parent - .alias classchildren -cmd ::xotcl::cmd::ObjectInfo::children - .alias info -source-object objectInfo -source-per-object -source-method info - .alias unknown -source-object objectInfo -source-per-object -source-method unknown + .alias is ::xotcl::is + .alias classparent ::xotcl::cmd::ObjectInfo::parent + .alias classchildren ::xotcl::cmd::ObjectInfo::children + .alias info [::xotcl::cmd::ObjectInfo::method objectInfo -per-object name info] + .alias unknown [::xotcl::cmd::ObjectInfo::method objectInfo -per-object name info] } foreach cmd [info command ::xotcl::cmd::ObjectInfo::*] { @@ -132,8 +115,8 @@ } unset cmd - Object instforward info -onerror ::xotcl::infoError ::xotcl2::objectInfo %1 {%@2 %self} - Class instforward info -onerror ::xotcl::infoError ::xotcl2::classInfo %1 {%@2 %self} + Object forward info -onerror ::xotcl::infoError ::xotcl2::objectInfo %1 {%@2 %self} + Class forward info -onerror ::xotcl::infoError ::xotcl2::classInfo %1 {%@2 %self} proc ::xotcl::infoError msg { #puts stderr "INFO ERROR: <$msg>\n$::errorInfo" @@ -282,7 +265,7 @@ ::xotcl::setinstvar ${class}::slot::$att default $default unset default } - $class instparametercmd $att + $class setter $att } # do a second round to ensure that the already defined objects @@ -368,13 +351,15 @@ } ::xotcl::Slot method init {args} { - set forwarder [expr {${.per-object} ? "forward" : "instforward"}] if {${.domain} eq ""} { set .domain [::xotcl::self callingobject] } if {${.domain} ne ""} { ${.domain} invalidateobjectparameter - ${.domain} $forwarder ${.name} -default [${.manager} defaultmethods] ${.manager} %1 %self %proc + # since the domain object might be xotcl1 or 2, use dispatch + ::xotcl::dispatch ${.domain} ::xotcl::cmd::Class::forward \ + {*}[expr {${.per-object} ? "-per-object" : ""}] ${.name} \ + -default [${.manager} defaultmethods] ${.manager} %1 %self %proc } } @@ -574,9 +559,8 @@ if {[set .defaultmethods] ne {get assign}} return if {[.procsearch assign] ne "::xotcl::Slot instcmd assign"} return if {[.procsearch get] ne "::xotcl::Slot instcmd get"} return - set forwarder [expr {[set .per-object] ? "parametercmd":"instparametercmd"}] #puts stderr "**** optimizing ${.domain} $forwarder ${.name}" - ${.domain} $forwarder ${.name} + ${.domain} setter {*}[expr {${.per-object} ? "-per-object" : ""}] ${.name} } } # register the optimizer per default @@ -627,7 +611,7 @@ namespace eval $object $cmds } } -::xotcl2::Class instforward slots %self contains \ +::xotcl2::Class forward slots %self contains \ -object {%::xotcl::dispatch [::xotcl::self] -objscope ::subst [::xotcl::self]::slot} ############################################ @@ -701,7 +685,7 @@ $po unset -nocomplain $instvar } } else { - .instparametercmd $name + .setter $name } } } Index: generic/tclAPI.h =================================================================== diff -u -rdb7c710aa3b6386c33af9a318876f21a88b8aafd -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 --- generic/tclAPI.h (.../tclAPI.h) (revision db7c710aa3b6386c33af9a318876f21a88b8aafd) +++ generic/tclAPI.h (.../tclAPI.h) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) @@ -1,4 +1,13 @@ +static int convertToInfomethodsubcmd(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { + int index, result; + static CONST char *opts[] = {"definition", "name", "type", NULL}; + result = Tcl_GetIndexFromObj(interp, objPtr, opts, "infomethodsubcmd", 0, &index); + *clientData = (ClientData) index + 1; + return result; +} +enum InfomethodsubcmdIdx {InfomethodsubcmdNULL, InfomethodsubcmdDefinitionIdx, InfomethodsubcmdNameIdx, InfomethodsubcmdTypeIdx}; + static int convertToMethodtype(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { int index, result; static CONST char *opts[] = {"all", "scripted", "system", "alias", "forwarder", "object", "setter", NULL}; @@ -58,7 +67,7 @@ char *methodName; Tcl_ObjCmdProc *proc; int nrParameters; - XOTclParam paramDefs[10]; + XOTclParam paramDefs[11]; } methodDefinition; static int ArgumentParse(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], @@ -83,28 +92,25 @@ static int XOTclCAllocMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCCreateMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCDeallocMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclCForwardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCInstFilterGuardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclCInstForwardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCInstMixinGuardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclCInstParametercmdMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCInvalidateObjectParameterMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCInvariantsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCMethodMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCNewMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCRecreateMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclCSetterMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoAliasMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoHeritageMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoInstancesMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclClassInfoInstbodyMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclClassInfoInstcommandsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoInstfilterMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoInstfilterguardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoInstforwardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoInstinvarMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoInstmixinMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoInstmixinguardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoInstmixinofMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclClassInfoInstparametercmdMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoInstparamsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoInstpostMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoInstpreMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -114,20 +120,18 @@ static int XOTclClassInfoSubclassMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoSuperclassMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoAliasMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclObjInfoBodyMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoCheckMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoChildrenMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoClassMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclObjInfoCommandsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoFilterMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoFilterguardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoForwardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoHasnamespaceMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoInvarMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclObjInfoMethodMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoMethodsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoMixinMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoMixinguardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclObjInfoParametercmdMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoParamsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoParentMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoPostMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -150,10 +154,10 @@ static int XOTclOMixinGuardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclONextMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclONoinitMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclOParametercmdMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOProcSearchMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclORequireNamespaceMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOResidualargsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclOSetterMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOUplevelMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOUpvarMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOVolatileMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -182,28 +186,25 @@ static int XOTclCAllocMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *name); static int XOTclCCreateMethod(Tcl_Interp *interp, XOTclClass *cl, char *name, int objc, Tcl_Obj *CONST objv[]); static int XOTclCDeallocMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *object); +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 XOTclCInstFilterGuardMethod(Tcl_Interp *interp, XOTclClass *cl, char *filter, Tcl_Obj *guard); -static int XOTclCInstForwardMethod(Tcl_Interp *interp, XOTclClass *cl, 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 XOTclCInstMixinGuardMethod(Tcl_Interp *interp, XOTclClass *cl, char *mixin, Tcl_Obj *guard); -static int XOTclCInstParametercmdMethod(Tcl_Interp *interp, XOTclClass *cl, char *name); 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 withProtected, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition); 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[]); +static int XOTclCSetterMethod(Tcl_Interp *interp, XOTclClass *cl, int withPer_object, char *name); static int XOTclClassInfoAliasMethod(Tcl_Interp *interp, XOTclClass *object, int withDefinition, int withPer_object, char *name); static int XOTclClassInfoHeritageMethod(Tcl_Interp *interp, XOTclClass *class, char *pattern); static int XOTclClassInfoInstancesMethod(Tcl_Interp *interp, XOTclClass *class, int withClosure, char *patternString, XOTclObject *patternObj); -static int XOTclClassInfoInstbodyMethod(Tcl_Interp *interp, XOTclClass *class, char *methodName); -static int XOTclClassInfoInstcommandsMethod(Tcl_Interp *interp, XOTclClass *class, char *pattern); static int XOTclClassInfoInstfilterMethod(Tcl_Interp *interp, XOTclClass *class, int withGuards, char *pattern); static int XOTclClassInfoInstfilterguardMethod(Tcl_Interp *interp, XOTclClass *class, char *filter); static int XOTclClassInfoInstforwardMethod(Tcl_Interp *interp, XOTclClass *class, int withDefinition, char *name); static int XOTclClassInfoInstinvarMethod(Tcl_Interp *interp, XOTclClass *class); static int XOTclClassInfoInstmixinMethod(Tcl_Interp *interp, XOTclClass *class, int withClosure, int withGuards, char *patternString, XOTclObject *patternObj); static int XOTclClassInfoInstmixinguardMethod(Tcl_Interp *interp, XOTclClass *class, char *mixin); static int XOTclClassInfoInstmixinofMethod(Tcl_Interp *interp, XOTclClass *class, int withClosure, char *patternString, XOTclObject *patternObj); -static int XOTclClassInfoInstparametercmdMethod(Tcl_Interp *interp, XOTclClass *class, char *pattern); static int XOTclClassInfoInstparamsMethod(Tcl_Interp *interp, XOTclClass *class, char *methodName, int withVarnames); static int XOTclClassInfoInstpostMethod(Tcl_Interp *interp, XOTclClass *class, char *methodName); static int XOTclClassInfoInstpreMethod(Tcl_Interp *interp, XOTclClass *class, char *methodName); @@ -213,20 +214,18 @@ static int XOTclClassInfoSubclassMethod(Tcl_Interp *interp, XOTclClass *class, int withClosure, char *patternString, XOTclObject *patternObj); static int XOTclClassInfoSuperclassMethod(Tcl_Interp *interp, XOTclClass *class, int withClosure, Tcl_Obj *pattern); static int XOTclObjInfoAliasMethod(Tcl_Interp *interp, XOTclObject *object, int withDefinition, char *name); -static int XOTclObjInfoBodyMethod(Tcl_Interp *interp, XOTclObject *object, char *methodName); static int XOTclObjInfoCheckMethod(Tcl_Interp *interp, XOTclObject *object); static int XOTclObjInfoChildrenMethod(Tcl_Interp *interp, XOTclObject *object, char *pattern); static int XOTclObjInfoClassMethod(Tcl_Interp *interp, XOTclObject *object); -static int XOTclObjInfoCommandsMethod(Tcl_Interp *interp, XOTclObject *object, char *pattern); static int XOTclObjInfoFilterMethod(Tcl_Interp *interp, XOTclObject *object, int withOrder, int withGuards, char *pattern); static int XOTclObjInfoFilterguardMethod(Tcl_Interp *interp, XOTclObject *object, char *filter); static int XOTclObjInfoForwardMethod(Tcl_Interp *interp, XOTclObject *object, int withDefinition, char *name); static int XOTclObjInfoHasnamespaceMethod(Tcl_Interp *interp, XOTclObject *object); static int XOTclObjInfoInvarMethod(Tcl_Interp *interp, XOTclObject *object); +static int XOTclObjInfoMethodMethod(Tcl_Interp *interp, XOTclObject *object, int withPer_object, int infomethodsubcmd, char *name); static int XOTclObjInfoMethodsMethod(Tcl_Interp *interp, XOTclObject *object, int withDefined, int withPer_object, int withMethodtype, int withNomixins, int withIncontext, char *pattern); static int XOTclObjInfoMixinMethod(Tcl_Interp *interp, XOTclObject *object, int withGuards, int withOrder, char *patternString, XOTclObject *patternObj); static int XOTclObjInfoMixinguardMethod(Tcl_Interp *interp, XOTclObject *object, char *mixin); -static int XOTclObjInfoParametercmdMethod(Tcl_Interp *interp, XOTclObject *object, char *pattern); static int XOTclObjInfoParamsMethod(Tcl_Interp *interp, XOTclObject *object, char *methodName, int withVarnames); static int XOTclObjInfoParentMethod(Tcl_Interp *interp, XOTclObject *object); static int XOTclObjInfoPostMethod(Tcl_Interp *interp, XOTclObject *object, char *methodName); @@ -249,10 +248,10 @@ static int XOTclOMixinGuardMethod(Tcl_Interp *interp, XOTclObject *obj, char *mixin, Tcl_Obj *guard); static int XOTclONextMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); static int XOTclONoinitMethod(Tcl_Interp *interp, XOTclObject *obj); -static int XOTclOParametercmdMethod(Tcl_Interp *interp, XOTclObject *obj, char *name); static int XOTclOProcSearchMethod(Tcl_Interp *interp, XOTclObject *obj, char *name); static int XOTclORequireNamespaceMethod(Tcl_Interp *interp, XOTclObject *obj); static int XOTclOResidualargsMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); +static int XOTclOSetterMethod(Tcl_Interp *interp, XOTclObject *obj, char *name); static int XOTclOUplevelMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); static int XOTclOUpvarMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); static int XOTclOVolatileMethod(Tcl_Interp *interp, XOTclObject *obj); @@ -282,28 +281,25 @@ XOTclCAllocMethodIdx, XOTclCCreateMethodIdx, XOTclCDeallocMethodIdx, + XOTclCForwardMethodIdx, XOTclCInstFilterGuardMethodIdx, - XOTclCInstForwardMethodIdx, XOTclCInstMixinGuardMethodIdx, - XOTclCInstParametercmdMethodIdx, XOTclCInvalidateObjectParameterMethodIdx, XOTclCInvariantsMethodIdx, XOTclCMethodMethodIdx, XOTclCNewMethodIdx, XOTclCRecreateMethodIdx, + XOTclCSetterMethodIdx, XOTclClassInfoAliasMethodIdx, XOTclClassInfoHeritageMethodIdx, XOTclClassInfoInstancesMethodIdx, - XOTclClassInfoInstbodyMethodIdx, - XOTclClassInfoInstcommandsMethodIdx, XOTclClassInfoInstfilterMethodIdx, XOTclClassInfoInstfilterguardMethodIdx, XOTclClassInfoInstforwardMethodIdx, XOTclClassInfoInstinvarMethodIdx, XOTclClassInfoInstmixinMethodIdx, XOTclClassInfoInstmixinguardMethodIdx, XOTclClassInfoInstmixinofMethodIdx, - XOTclClassInfoInstparametercmdMethodIdx, XOTclClassInfoInstparamsMethodIdx, XOTclClassInfoInstpostMethodIdx, XOTclClassInfoInstpreMethodIdx, @@ -313,20 +309,18 @@ XOTclClassInfoSubclassMethodIdx, XOTclClassInfoSuperclassMethodIdx, XOTclObjInfoAliasMethodIdx, - XOTclObjInfoBodyMethodIdx, XOTclObjInfoCheckMethodIdx, XOTclObjInfoChildrenMethodIdx, XOTclObjInfoClassMethodIdx, - XOTclObjInfoCommandsMethodIdx, XOTclObjInfoFilterMethodIdx, XOTclObjInfoFilterguardMethodIdx, XOTclObjInfoForwardMethodIdx, XOTclObjInfoHasnamespaceMethodIdx, XOTclObjInfoInvarMethodIdx, + XOTclObjInfoMethodMethodIdx, XOTclObjInfoMethodsMethodIdx, XOTclObjInfoMixinMethodIdx, XOTclObjInfoMixinguardMethodIdx, - XOTclObjInfoParametercmdMethodIdx, XOTclObjInfoParamsMethodIdx, XOTclObjInfoParentMethodIdx, XOTclObjInfoPostMethodIdx, @@ -349,10 +343,10 @@ XOTclOMixinGuardMethodIdx, XOTclONextMethodIdx, XOTclONoinitMethodIdx, - XOTclOParametercmdMethodIdx, XOTclOProcSearchMethodIdx, XOTclORequireNamespaceMethodIdx, XOTclOResidualargsMethodIdx, + XOTclOSetterMethodIdx, XOTclOUplevelMethodIdx, XOTclOUpvarMethodIdx, XOTclOVolatileMethodIdx, @@ -474,47 +468,48 @@ } static int -XOTclCInstFilterGuardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { +XOTclCForwardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; XOTclClass *cl = XOTclObjectToClass(clientData); if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); if (ArgumentParse(interp, objc, objv, (XOTclObject *) cl, objv[0], - method_definitions[XOTclCInstFilterGuardMethodIdx].paramDefs, - method_definitions[XOTclCInstFilterGuardMethodIdx].nrParameters, + method_definitions[XOTclCForwardMethodIdx].paramDefs, + method_definitions[XOTclCForwardMethodIdx].nrParameters, &pc) != TCL_OK) { return TCL_ERROR; } else { - char *filter = (char *)pc.clientData[0]; - Tcl_Obj *guard = (Tcl_Obj *)pc.clientData[1]; + int withPer_object = (int )pc.clientData[0]; + Tcl_Obj *name = (Tcl_Obj *)pc.clientData[1]; + Tcl_Obj *withDefault = (Tcl_Obj *)pc.clientData[2]; + int withEarlybinding = (int )pc.clientData[3]; + Tcl_Obj *withMethodprefix = (Tcl_Obj *)pc.clientData[4]; + int withObjscope = (int )pc.clientData[5]; + Tcl_Obj *withOnerror = (Tcl_Obj *)pc.clientData[6]; + int withVerbose = (int )pc.clientData[7]; + Tcl_Obj *target = (Tcl_Obj *)pc.clientData[8]; parseContextRelease(&pc); - return XOTclCInstFilterGuardMethod(interp, cl, filter, guard); + return XOTclCForwardMethod(interp, cl, withPer_object, name, withDefault, withEarlybinding, withMethodprefix, withObjscope, withOnerror, withVerbose, target, objc-pc.lastobjc, objv+pc.lastobjc); } } static int -XOTclCInstForwardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { +XOTclCInstFilterGuardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; XOTclClass *cl = XOTclObjectToClass(clientData); if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); if (ArgumentParse(interp, objc, objv, (XOTclObject *) cl, objv[0], - method_definitions[XOTclCInstForwardMethodIdx].paramDefs, - method_definitions[XOTclCInstForwardMethodIdx].nrParameters, + method_definitions[XOTclCInstFilterGuardMethodIdx].paramDefs, + method_definitions[XOTclCInstFilterGuardMethodIdx].nrParameters, &pc) != TCL_OK) { return TCL_ERROR; } else { - Tcl_Obj *name = (Tcl_Obj *)pc.clientData[0]; - Tcl_Obj *withDefault = (Tcl_Obj *)pc.clientData[1]; - int withEarlybinding = (int )pc.clientData[2]; - Tcl_Obj *withMethodprefix = (Tcl_Obj *)pc.clientData[3]; - int withObjscope = (int )pc.clientData[4]; - Tcl_Obj *withOnerror = (Tcl_Obj *)pc.clientData[5]; - int withVerbose = (int )pc.clientData[6]; - Tcl_Obj *target = (Tcl_Obj *)pc.clientData[7]; + char *filter = (char *)pc.clientData[0]; + Tcl_Obj *guard = (Tcl_Obj *)pc.clientData[1]; parseContextRelease(&pc); - return XOTclCInstForwardMethod(interp, cl, name, withDefault, withEarlybinding, withMethodprefix, withObjscope, withOnerror, withVerbose, target, objc-pc.lastobjc, objv+pc.lastobjc); + return XOTclCInstFilterGuardMethod(interp, cl, filter, guard); } } @@ -540,25 +535,6 @@ } static int -XOTclCInstParametercmdMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - XOTclClass *cl = XOTclObjectToClass(clientData); - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (ArgumentParse(interp, objc, objv, (XOTclObject *) cl, objv[0], - method_definitions[XOTclCInstParametercmdMethodIdx].paramDefs, - method_definitions[XOTclCInstParametercmdMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - char *name = (char *)pc.clientData[0]; - - parseContextRelease(&pc); - return XOTclCInstParametercmdMethod(interp, cl, name); - - } -} - -static int XOTclCInvalidateObjectParameterMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; XOTclClass *cl = XOTclObjectToClass(clientData); @@ -661,6 +637,26 @@ } static int +XOTclCSetterMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + XOTclClass *cl = XOTclObjectToClass(clientData); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (ArgumentParse(interp, objc, objv, (XOTclObject *) cl, objv[0], + method_definitions[XOTclCSetterMethodIdx].paramDefs, + method_definitions[XOTclCSetterMethodIdx].nrParameters, + &pc) != TCL_OK) { + return TCL_ERROR; + } else { + int withPer_object = (int )pc.clientData[0]; + char *name = (char *)pc.clientData[1]; + + parseContextRelease(&pc); + return XOTclCSetterMethod(interp, cl, withPer_object, name); + + } +} + +static int XOTclClassInfoAliasMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -735,44 +731,6 @@ } static int -XOTclClassInfoInstbodyMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - - if (ArgumentParse(interp, objc, objv, NULL, objv[0], - method_definitions[XOTclClassInfoInstbodyMethodIdx].paramDefs, - method_definitions[XOTclClassInfoInstbodyMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - XOTclClass *class = (XOTclClass *)pc.clientData[0]; - char *methodName = (char *)pc.clientData[1]; - - parseContextRelease(&pc); - return XOTclClassInfoInstbodyMethod(interp, class, methodName); - - } -} - -static int -XOTclClassInfoInstcommandsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - - if (ArgumentParse(interp, objc, objv, NULL, objv[0], - method_definitions[XOTclClassInfoInstcommandsMethodIdx].paramDefs, - method_definitions[XOTclClassInfoInstcommandsMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - XOTclClass *class = (XOTclClass *)pc.clientData[0]; - char *pattern = (char *)pc.clientData[1]; - - parseContextRelease(&pc); - return XOTclClassInfoInstcommandsMethod(interp, class, pattern); - - } -} - -static int XOTclClassInfoInstfilterMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -938,25 +896,6 @@ } static int -XOTclClassInfoInstparametercmdMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - - if (ArgumentParse(interp, objc, objv, NULL, objv[0], - method_definitions[XOTclClassInfoInstparametercmdMethodIdx].paramDefs, - method_definitions[XOTclClassInfoInstparametercmdMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - XOTclClass *class = (XOTclClass *)pc.clientData[0]; - char *pattern = (char *)pc.clientData[1]; - - parseContextRelease(&pc); - return XOTclClassInfoInstparametercmdMethod(interp, class, pattern); - - } -} - -static int XOTclClassInfoInstparamsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -1159,25 +1098,6 @@ } static int -XOTclObjInfoBodyMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - - if (ArgumentParse(interp, objc, objv, NULL, objv[0], - method_definitions[XOTclObjInfoBodyMethodIdx].paramDefs, - method_definitions[XOTclObjInfoBodyMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - XOTclObject *object = (XOTclObject *)pc.clientData[0]; - char *methodName = (char *)pc.clientData[1]; - - parseContextRelease(&pc); - return XOTclObjInfoBodyMethod(interp, object, methodName); - - } -} - -static int XOTclObjInfoCheckMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -1233,25 +1153,6 @@ } static int -XOTclObjInfoCommandsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - - if (ArgumentParse(interp, objc, objv, NULL, objv[0], - method_definitions[XOTclObjInfoCommandsMethodIdx].paramDefs, - method_definitions[XOTclObjInfoCommandsMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - XOTclObject *object = (XOTclObject *)pc.clientData[0]; - char *pattern = (char *)pc.clientData[1]; - - parseContextRelease(&pc); - return XOTclObjInfoCommandsMethod(interp, object, pattern); - - } -} - -static int XOTclObjInfoFilterMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -1348,6 +1249,27 @@ } static int +XOTclObjInfoMethodMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + + if (ArgumentParse(interp, objc, objv, NULL, objv[0], + method_definitions[XOTclObjInfoMethodMethodIdx].paramDefs, + method_definitions[XOTclObjInfoMethodMethodIdx].nrParameters, + &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclObject *object = (XOTclObject *)pc.clientData[0]; + int withPer_object = (int )pc.clientData[1]; + int infomethodsubcmd = (int )pc.clientData[2]; + char *name = (char *)pc.clientData[3]; + + parseContextRelease(&pc); + return XOTclObjInfoMethodMethod(interp, object, withPer_object, infomethodsubcmd, name); + + } +} + +static int XOTclObjInfoMethodsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -1426,25 +1348,6 @@ } static int -XOTclObjInfoParametercmdMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - - if (ArgumentParse(interp, objc, objv, NULL, objv[0], - method_definitions[XOTclObjInfoParametercmdMethodIdx].paramDefs, - method_definitions[XOTclObjInfoParametercmdMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - XOTclObject *object = (XOTclObject *)pc.clientData[0]; - char *pattern = (char *)pc.clientData[1]; - - parseContextRelease(&pc); - return XOTclObjInfoParametercmdMethod(interp, object, pattern); - - } -} - -static int XOTclObjInfoParamsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -1854,25 +1757,6 @@ } static int -XOTclOParametercmdMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - XOTclObject *obj = (XOTclObject *)clientData; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (ArgumentParse(interp, objc, objv, obj, objv[0], - method_definitions[XOTclOParametercmdMethodIdx].paramDefs, - method_definitions[XOTclOParametercmdMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - char *name = (char *)pc.clientData[0]; - - parseContextRelease(&pc); - return XOTclOParametercmdMethod(interp, obj, name); - - } -} - -static int XOTclOProcSearchMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; XOTclObject *obj = (XOTclObject *)clientData; @@ -1921,6 +1805,25 @@ } static int +XOTclOSetterMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + XOTclObject *obj = (XOTclObject *)clientData; + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (ArgumentParse(interp, objc, objv, obj, objv[0], + method_definitions[XOTclOSetterMethodIdx].paramDefs, + method_definitions[XOTclOSetterMethodIdx].nrParameters, + &pc) != TCL_OK) { + return TCL_ERROR; + } else { + char *name = (char *)pc.clientData[0]; + + parseContextRelease(&pc); + return XOTclOSetterMethod(interp, obj, name); + + } +} + +static int XOTclOUplevelMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { XOTclObject *obj = (XOTclObject *)clientData; if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); @@ -2335,11 +2238,8 @@ {"::xotcl::cmd::Class::dealloc", XOTclCDeallocMethodStub, 1, { {"object", 1, 0, convertToTclobj}} }, -{"::xotcl::cmd::Class::instfilterguard", XOTclCInstFilterGuardMethodStub, 2, { - {"filter", 1, 0, convertToString}, - {"guard", 1, 0, convertToTclobj}} -}, -{"::xotcl::cmd::Class::instforward", XOTclCInstForwardMethodStub, 9, { +{"::xotcl::cmd::Class::forward", XOTclCForwardMethodStub, 10, { + {"-per-object", 0, 0, convertToBoolean}, {"name", 1, 0, convertToTclobj}, {"-default", 0, 1, convertToTclobj}, {"-earlybinding", 0, 0, convertToString}, @@ -2350,13 +2250,14 @@ {"target", 0, 0, convertToTclobj}, {"args", 0, 0, convertToNothing}} }, +{"::xotcl::cmd::Class::instfilterguard", XOTclCInstFilterGuardMethodStub, 2, { + {"filter", 1, 0, convertToString}, + {"guard", 1, 0, convertToTclobj}} +}, {"::xotcl::cmd::Class::instmixinguard", XOTclCInstMixinGuardMethodStub, 2, { {"mixin", 1, 0, convertToString}, {"guard", 1, 0, convertToTclobj}} }, -{"::xotcl::cmd::Class::instparametercmd", XOTclCInstParametercmdMethodStub, 1, { - {"name", 1, 0, convertToString}} -}, {"::xotcl::cmd::Class::invalidateobjectparameter", XOTclCInvalidateObjectParameterMethodStub, 0, { } }, @@ -2381,6 +2282,10 @@ {"name", 1, 0, convertToTclobj}, {"args", 0, 0, convertToNothing}} }, +{"::xotcl::cmd::Class::setter", XOTclCSetterMethodStub, 2, { + {"-per-object", 0, 0, convertToBoolean}, + {"name", 1, 0, convertToString}} +}, {"::xotcl::cmd::ClassInfo::alias", XOTclClassInfoAliasMethodStub, 4, { {"object", 1, 0, convertToClass}, {"-definition", 0, 0, convertToString}, @@ -2396,14 +2301,6 @@ {"-closure", 0, 0, convertToString}, {"pattern", 0, 0, convertToObjpattern}} }, -{"::xotcl::cmd::ClassInfo::instbody", XOTclClassInfoInstbodyMethodStub, 2, { - {"class", 1, 0, convertToClass}, - {"methodName", 1, 0, convertToString}} -}, -{"::xotcl::cmd::ClassInfo::instcommands", XOTclClassInfoInstcommandsMethodStub, 2, { - {"class", 1, 0, convertToClass}, - {"pattern", 0, 0, convertToString}} -}, {"::xotcl::cmd::ClassInfo::instfilter", XOTclClassInfoInstfilterMethodStub, 3, { {"class", 1, 0, convertToClass}, {"-guards", 0, 0, convertToString}, @@ -2436,10 +2333,6 @@ {"-closure", 0, 0, convertToString}, {"pattern", 0, 0, convertToObjpattern}} }, -{"::xotcl::cmd::ClassInfo::instparametercmd", XOTclClassInfoInstparametercmdMethodStub, 2, { - {"class", 1, 0, convertToClass}, - {"pattern", 0, 0, convertToString}} -}, {"::xotcl::cmd::ClassInfo::instparams", XOTclClassInfoInstparamsMethodStub, 3, { {"class", 1, 0, convertToClass}, {"methodName", 1, 0, convertToString}, @@ -2479,10 +2372,6 @@ {"-definition", 0, 0, convertToString}, {"name", 0, 0, convertToString}} }, -{"::xotcl::cmd::ObjectInfo::body", XOTclObjInfoBodyMethodStub, 2, { - {"object", 1, 0, convertToObject}, - {"methodName", 1, 0, convertToString}} -}, {"::xotcl::cmd::ObjectInfo::check", XOTclObjInfoCheckMethodStub, 1, { {"object", 1, 0, convertToObject}} }, @@ -2493,10 +2382,6 @@ {"::xotcl::cmd::ObjectInfo::class", XOTclObjInfoClassMethodStub, 1, { {"object", 1, 0, convertToObject}} }, -{"::xotcl::cmd::ObjectInfo::commands", XOTclObjInfoCommandsMethodStub, 2, { - {"object", 1, 0, convertToObject}, - {"pattern", 0, 0, convertToString}} -}, {"::xotcl::cmd::ObjectInfo::filter", XOTclObjInfoFilterMethodStub, 4, { {"object", 1, 0, convertToObject}, {"-order", 0, 0, convertToString}, @@ -2518,6 +2403,12 @@ {"::xotcl::cmd::ObjectInfo::invar", XOTclObjInfoInvarMethodStub, 1, { {"object", 1, 0, convertToObject}} }, +{"::xotcl::cmd::ObjectInfo::method", XOTclObjInfoMethodMethodStub, 4, { + {"object", 1, 0, convertToObject}, + {"-per-object", 0, 0, convertToString}, + {"infomethodsubcmd", 0, 0, convertToInfomethodsubcmd}, + {"name", 0, 0, convertToString}} +}, {"::xotcl::cmd::ObjectInfo::methods", XOTclObjInfoMethodsMethodStub, 7, { {"object", 1, 0, convertToObject}, {"-defined", 0, 0, convertToString}, @@ -2537,10 +2428,6 @@ {"object", 1, 0, convertToObject}, {"mixin", 1, 0, convertToString}} }, -{"::xotcl::cmd::ObjectInfo::parametercmd", XOTclObjInfoParametercmdMethodStub, 2, { - {"object", 1, 0, convertToObject}, - {"pattern", 0, 0, convertToString}} -}, {"::xotcl::cmd::ObjectInfo::params", XOTclObjInfoParamsMethodStub, 3, { {"object", 1, 0, convertToObject}, {"methodName", 1, 0, convertToString}, @@ -2633,9 +2520,6 @@ {"::xotcl::cmd::Object::noinit", XOTclONoinitMethodStub, 0, { } }, -{"::xotcl::cmd::Object::parametercmd", XOTclOParametercmdMethodStub, 1, { - {"name", 1, 0, convertToString}} -}, {"::xotcl::cmd::Object::procsearch", XOTclOProcSearchMethodStub, 1, { {"name", 1, 0, convertToString}} }, @@ -2645,6 +2529,9 @@ {"::xotcl::cmd::Object::residualargs", XOTclOResidualargsMethodStub, 1, { {"args", 0, 0, convertToNothing}} }, +{"::xotcl::cmd::Object::setter", XOTclOSetterMethodStub, 1, { + {"name", 1, 0, convertToString}} +}, {"::xotcl::cmd::Object::uplevel", XOTclOUplevelMethodStub, 1, { {"args", 0, 0, convertToNothing}} }, Index: generic/xotcl.c =================================================================== diff -u -r594443fc204cdb7338f03998db2ca1c7dd5d102a -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 --- generic/xotcl.c (.../xotcl.c) (revision 594443fc204cdb7338f03998db2ca1c7dd5d102a) +++ generic/xotcl.c (.../xotcl.c) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) @@ -1289,7 +1289,7 @@ return (Tcl_Command_objProc(cmd) == TclObjInterpProc); } -static Proc *GetProcFromCommand(Tcl_Command cmd) { +static Proc *GetTclProcFromCommand(Tcl_Command cmd) { if (cmd) { Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); if (proc == TclObjInterpProc) @@ -1310,7 +1310,7 @@ static Proc * FindProcMethod(Tcl_Namespace *nsPtr, char *methodName) { - return GetProcFromCommand(FindMethod(nsPtr, methodName)); + return GetTclProcFromCommand(FindMethod(nsPtr, methodName)); } static XOTclClass* @@ -1939,7 +1939,7 @@ /* * cmd is an aliased object, reduce the refcount */ - fprintf(stderr, "NSCleanupNamespace cleanup aliased object %p\n",invokeObj); + /*fprintf(stderr, "NSCleanupNamespace cleanup aliased object %p\n",invokeObj);*/ XOTclCleanupObject(invokeObj); } @@ -2663,16 +2663,15 @@ static Tcl_Obj * AssertionList(Tcl_Interp *interp, XOTclTclObjList *alist) { - Tcl_Obj *newAssStr = Tcl_NewStringObj("", 0); + Tcl_Obj *listObj = Tcl_NewListObj(0, NULL); for (; alist; alist = alist->nextPtr) { - Tcl_AppendStringsToObj(newAssStr, "{", ObjStr(alist->content), - "}", (char *) NULL); - if (alist->nextPtr) - Tcl_AppendStringsToObj(newAssStr, " ", (char *) NULL); + Tcl_ListObjAppendElement(interp, listObj, alist->content); } - return newAssStr; + return listObj; } + + /* append a string of pre and post assertions to a proc or instproc body */ static void @@ -6497,7 +6496,7 @@ for (i=0; ineedobjmap |= (*element == '%' && *(element+1) == '@'); if (tcd->args == NULL) { tcd->args = Tcl_NewListObj(1, &objv[i]); @@ -9172,7 +9171,7 @@ XOTclObject *obj, Tcl_Obj *procNameObj, XOTclParam CONST *paramPtr, int nrParams, parseContext *pc) { - int i, o, flagCount = 0, nrReq = 0, nrOpt = 0, dashdash = 0, nrDashdash = 0; + int i, o, flagCount, nrReq = 0, nrOpt = 0, dashdash = 0, nrDashdash = 0; /* todo benchmark with and without CONST */ XOTclParam CONST *pPtr; @@ -9189,6 +9188,7 @@ fprintf(stderr, "... (%d) processing [%d]: '%s' %s\n", i, o, pPtr->name,pPtr->flags & XOTCL_ARG_REQUIRED ? "req":"not req"); #endif + flagCount = 0; if (*pPtr->name == '-') { int p, found; char *objStr; @@ -9317,15 +9317,14 @@ } return ArgumentDefaults(pc, interp, paramPtr, nrParams); - - return TCL_OK; } /*********************************** * Begin result setting commands * (essentially List*() and support ***********************************/ +#if defined(PRE85) static int ListKeys(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern) { Tcl_HashEntry *hPtr; @@ -9353,6 +9352,7 @@ } return TCL_OK; } +#endif #if !defined(PRE85) || FORWARD_COMPATIBLE static int @@ -9410,12 +9410,249 @@ return cmd; } +/* proc/instproc specific code */ +static int +ListProcBody(Tcl_Interp *interp, Proc *procPtr, char *methodName) { + if (procPtr) { + char *body = ObjStr(procPtr->bodyPtr); + Tcl_SetObjResult(interp, Tcl_NewStringObj(StripBodyPrefix(body), -1)); + return TCL_OK; + } + return XOTclErrBadVal(interp, "info body", "a tcl method name", methodName); +} static int +ListCmdParams(Tcl_Interp *interp, Tcl_Command cmd, char *methodName, int withVarnames) { + Proc *procPtr = GetTclProcFromCommand(cmd); + if (procPtr) { + XOTclParamDefs *paramDefs = procPtr ? ParamDefsGet((Tcl_Command)procPtr->cmdPtr) : NULL; + Tcl_Obj *list; + + if (paramDefs) { + /* + * Obtain parameter info from paramDefs + */ + list = withVarnames ? ParamDefsList(interp, paramDefs) : ParamDefsFormat(interp, paramDefs); + + } else { + /* + * Obtain parameter info from compiled locals + */ + CompiledLocal *args = procPtr->firstLocalPtr; + + list = Tcl_NewListObj(0, NULL); + for ( ; args; args = args->nextPtr) { + Tcl_Obj *innerlist; + + if (!TclIsCompiledLocalArgument(args)) { + continue; + } + + innerlist = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, innerlist, Tcl_NewStringObj(args->name, -1)); + if (!withVarnames && args->defValuePtr) { + Tcl_ListObjAppendElement(interp, innerlist, args->defValuePtr); + } + Tcl_ListObjAppendElement(interp, list, innerlist); + } + } + + Tcl_SetObjResult(interp, list); + return TCL_OK; + + } else if (cmd) { + /* + * If a command is found for the object|class, check whether we + * find the parameter definitions for the C-defined method. + */ + methodDefinition *mdPtr = &method_definitions[0]; + for (; mdPtr->methodName; mdPtr ++) { + if (((Command *)cmd)->objProc == mdPtr->proc) { + XOTclParamDefs paramDefs = {mdPtr->paramDefs, mdPtr->nrParameters}; + Tcl_Obj *list = withVarnames ? ParamDefsList(interp, ¶mDefs) : ParamDefsFormat(interp, ¶mDefs); + Tcl_SetObjResult(interp, list); + return TCL_OK; + } + } + return XOTclVarErrMsg(interp, "info params: could not obtain parameter definition for method '", + methodName, "'", (char *) NULL); + } + return XOTclErrBadVal(interp, "info params", "a method name", methodName); +} + +static void +AppendForwardDefinition(Tcl_Interp *interp, Tcl_Obj *listObj, forwardCmdClientData *tcd) { + if (tcd->prefix) { + Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-methodprefix",-1)); + Tcl_ListObjAppendElement(interp, listObj, tcd->prefix); + } + if (tcd->subcommands) { + Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-default",-1)); + Tcl_ListObjAppendElement(interp, listObj, tcd->subcommands); + } + if (tcd->objscope) { + Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-objscope",-1)); + } + Tcl_ListObjAppendElement(interp, listObj, tcd->cmdName); + if (tcd->args) { + Tcl_Obj **args; + int nrArgs, i; + Tcl_ListObjGetElements(interp, tcd->args, &nrArgs, &args); + for (i=0; icmdName); + Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(registerCmdName,-1)); + if (withPer_object) { + Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-per-object",-1)); + } + Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(methodName,-1)); +} + +static int +ListMethod(Tcl_Interp *interp, XOTclObject *object, char *methodName, Tcl_Command cmd, + int subcmd, int withPer_object) { + + /*fprintf(stderr, "ListMethodtype %s %s %p subcmd %d per-object %d\n", + objectName(object), methodName, cmd, subcmd, withPer_object);*/ + + if (!cmd) { + Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); + } else { + Tcl_ObjCmdProc *procPtr = Tcl_Command_objProc(cmd); + /*Tcl_Command importedCmd = GetOriginalCommand(cmd);*/ + /* Tcl_ObjCmdProc *resolvedProc = Tcl_Command_objProc(importedCmd);*/ + Tcl_Obj *resultObj; + + if (!XOTclObjectIsClass(object)) { + withPer_object = 1; + } + + if (subcmd == InfomethodsubcmdNameIdx) { + resultObj = Tcl_NewStringObj(withPer_object ? "" : "::xotcl::classes", -1); + Tcl_AppendObjToObj(resultObj, object->cmdName); + Tcl_AppendStringsToObj(resultObj, "::", methodName, (char *) NULL); + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; + } + + /* + * Subcommands different per type of method. converter in + * InfoMethods defines the types: + * "all|scripted|system|alias|forwarder|object|setter" + */ + if (GetTclProcFromCommand(cmd)) { + /* a scripted method */ + switch (subcmd) { + + case InfomethodsubcmdTypeIdx: + Tcl_SetObjResult(interp, Tcl_NewStringObj("scripted",-1)); + break; + + case InfomethodsubcmdDefinitionIdx: + { + XOTclAssertionStore *assertions; + + resultObj = Tcl_NewListObj(0, NULL); + /* todo: don't hard-code registering command name "method" */ + AppendMethodRegistration(interp, resultObj, "method", object, methodName, cmd, withPer_object); + ListCmdParams(interp, cmd, methodName, 0); + Tcl_ListObjAppendElement(interp, resultObj, Tcl_GetObjResult(interp)); + ListProcBody(interp, GetTclProcFromCommand(cmd), methodName); + Tcl_ListObjAppendElement(interp, resultObj, Tcl_GetObjResult(interp)); + + if (withPer_object) { + assertions = object->opt ? object->opt->assertions : NULL; + } else { + XOTclClass *class = (XOTclClass *)object; + assertions = class->opt ? class->opt->assertions : NULL; + } + if (assertions) { + XOTclProcAssertion *procs = AssertionFindProcs(assertions, methodName); + if (procs) { + Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("-precondition", -1)); + Tcl_ListObjAppendElement(interp, resultObj, AssertionList(interp, procs->pre)); + Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj("-postcondition", -1)); + Tcl_ListObjAppendElement(interp, resultObj, AssertionList(interp, procs->post)); + } + } + Tcl_SetObjResult(interp, resultObj); + break; + } + } + + } else if (procPtr == XOTclForwardMethod) { + /* forwarder */ + switch (subcmd) { + case InfomethodsubcmdTypeIdx: + Tcl_SetObjResult(interp, Tcl_NewStringObj("forward",-1)); + break; + case InfomethodsubcmdDefinitionIdx: + { + ClientData clientData = cmd ? Tcl_Command_objClientData(cmd) : NULL; + if (clientData) { + resultObj = Tcl_NewListObj(0, NULL); + /* todo: don't hard-code registering command name "forward" */ + AppendMethodRegistration(interp, resultObj, "forward", object, methodName, cmd, withPer_object); + AppendForwardDefinition(interp, resultObj, clientData); + Tcl_SetObjResult(interp, resultObj); + break; + } + } + } + + } else if (procPtr == XOTclSetterMethod) { + /* setter methods */ + switch (subcmd) { + case InfomethodsubcmdTypeIdx: + Tcl_SetObjResult(interp, Tcl_NewStringObj("setter",-1)); + break; + case InfomethodsubcmdDefinitionIdx: + resultObj = Tcl_NewListObj(0, NULL); + /* todo: don't hard-code registering command name "setter" */ + AppendMethodRegistration(interp, resultObj, "setter", object, methodName, cmd, withPer_object); + Tcl_SetObjResult(interp, resultObj); + break; + } + + } else { + /* must be an alias */ + switch (subcmd) { + case InfomethodsubcmdTypeIdx: + Tcl_SetObjResult(interp, Tcl_NewStringObj("alias",-1)); + break; + case InfomethodsubcmdDefinitionIdx: + { + Tcl_Obj *entryObj = AliasGet(interp, object->cmdName, methodName, withPer_object); + if (entryObj) { + resultObj = Tcl_NewListObj(0, NULL); + /* todo: don't hard-code registering command name "alias" */ + AppendMethodRegistration(interp, resultObj, "alias", object, methodName, cmd, withPer_object); + Tcl_ListObjAppendElement(interp, resultObj, entryObj); + Tcl_SetObjResult(interp, resultObj); + break; + } + } + } + } + } + return TCL_OK; +} + +static int ListMethodKeys(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern, int methodType, Tcl_HashTable *dups, XOTclObject *object, int withPer_object) { Tcl_HashSearch hSrch; Tcl_HashEntry *hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; + + /* TODO: could be made faster, when pattern contains no wild cards */ + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { char *key = Tcl_GetHashKey(table, hPtr); Tcl_Command importedCmd, cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); @@ -9556,7 +9793,6 @@ static int ListForward(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern, int withDefinition) { - int result; if (withDefinition) { Tcl_HashEntry *hPtr = table && pattern ? XOTcl_FindHashEntry(table, pattern) : 0; /* notice: we don't use pattern for wildcard matching here; @@ -9566,40 +9802,16 @@ Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); ClientData clientData = cmd? Tcl_Command_objClientData(cmd) : NULL; forwardCmdClientData *tcd = (forwardCmdClientData *)clientData; - if (tcd) { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - if (tcd->prefix) { - Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj("-methodprefix",-1)); - Tcl_ListObjAppendElement(interp, list, tcd->prefix); - } - if (tcd->subcommands) { - Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj("-default",-1)); - Tcl_ListObjAppendElement(interp, list, tcd->subcommands); - } - if (tcd->objscope) { - Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj("-objscope",-1)); - } - Tcl_ListObjAppendElement(interp, list, tcd->cmdName); - if (tcd->args) { - Tcl_Obj **args; - int nrArgs, i; - Tcl_ListObjGetElements(interp, tcd->args, &nrArgs, &args); - for (i=0; ibodyPtr); - Tcl_SetObjResult(interp, Tcl_NewStringObj(StripBodyPrefix(body), -1)); - return TCL_OK; - } - return XOTclErrBadVal(interp, "info body", "a tcl method name", methodName); -} - -static int -ListCmdParams(Tcl_Interp *interp, Tcl_Command cmd, char *methodName, int withVarnames) { - Proc *procPtr = GetProcFromCommand(cmd); - if (procPtr) { - XOTclParamDefs *paramDefs = procPtr ? ParamDefsGet((Tcl_Command)procPtr->cmdPtr) : NULL; - Tcl_Obj *list; - - if (paramDefs) { - /* - * Obtain parameter info from paramDefs - */ - list = withVarnames ? ParamDefsList(interp, paramDefs) : ParamDefsFormat(interp, paramDefs); - - } else { - /* - * Obtain parameter info from compiled locals - */ - CompiledLocal *args = procPtr->firstLocalPtr; - - list = Tcl_NewListObj(0, NULL); - for ( ; args; args = args->nextPtr) { - Tcl_Obj *innerlist; - - if (!TclIsCompiledLocalArgument(args)) { - continue; - } - - innerlist = Tcl_NewListObj(0, NULL); - Tcl_ListObjAppendElement(interp, innerlist, Tcl_NewStringObj(args->name, -1)); - if (!withVarnames && args->defValuePtr) { - Tcl_ListObjAppendElement(interp, innerlist, args->defValuePtr); - } - Tcl_ListObjAppendElement(interp, list, innerlist); - } - } - - Tcl_SetObjResult(interp, list); - return TCL_OK; - - } else if (cmd) { - /* - * If a command is found for the object|class, check whether we - * find the parameter definitions for the C-defined method. - */ - methodDefinition *mdPtr = &method_definitions[0]; - for (; mdPtr->methodName; mdPtr ++) { - if (((Command *)cmd)->objProc == mdPtr->proc) { - XOTclParamDefs paramDefs = {mdPtr->paramDefs, mdPtr->nrParameters}; - Tcl_Obj *list = withVarnames ? ParamDefsList(interp, ¶mDefs) : ParamDefsFormat(interp, ¶mDefs); - Tcl_SetObjResult(interp, list); - return TCL_OK; - } - } - return XOTclVarErrMsg(interp, "info params: could not obtain parameter definition for method '", - methodName, "'", (char *) NULL); - } - return XOTclErrBadVal(interp, "info params", "a method name", methodName); -} /******************************** * End result setting commands ********************************/ @@ -9897,7 +10040,7 @@ * alias points to nowhere. We realize this via using the object * refcount. */ - fprintf(stderr, "registering an object %p\n",tcd); + /*fprintf(stderr, "registering an object %p\n",tcd);*/ XOTclObjectRefCountIncr((XOTclObject *)Tcl_Command_objClientData(cmd)); @@ -9963,7 +10106,7 @@ if (newCmd) { Tcl_DString ds, *dsPtr = &ds; Tcl_DStringInit(dsPtr); - if (withPer_object) {Tcl_DStringAppend(dsPtr, "-per-object ", -1);} + /*if (withPer_object) {Tcl_DStringAppend(dsPtr, "-per-object ", -1);}*/ if (withObjscope) {Tcl_DStringAppend(dsPtr, "-objscope ", -1);} if (withProtected) {Tcl_DStringAppend(dsPtr, "-protected ", -1);} Tcl_DStringAppend(dsPtr, ObjStr(cmdName), -1); @@ -11559,9 +11702,10 @@ return TCL_OK; } -static int XOTclOParametercmdMethod(Tcl_Interp *interp, XOTclObject *obj, char *name) { + +/*static int XOTclOParametercmdMethod(Tcl_Interp *interp, XOTclObject *obj, char *name) { return XOTclAddObjectMethod(interp, (XOTcl_Object*) obj, name, (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0, 0); -} + }*/ static int XOTclOProcSearchMethod(Tcl_Interp *interp, XOTclObject *obj, char *name) { XOTclClass *pcl = NULL; @@ -11669,6 +11813,7 @@ int withObjscope, Tcl_Obj *withOnerror, int withVerbose, Tcl_Obj *target, int nobjc, Tcl_Obj *CONST nobjv[]) { forwardCmdClientData *tcd; + int result = forwardProcessOptions(interp, method, withDefault, withEarlybinding, withMethodprefix, withObjscope, withOnerror, withVerbose, @@ -12070,10 +12215,18 @@ return XOTclVarErrMsg(interp, "Instmixinguard: can't find mixin ", mixin, " on ", className(cl), (char *) NULL); } - -static int XOTclCInstParametercmdMethod(Tcl_Interp *interp, XOTclClass *cl, char *name) { - return XOTclAddInstanceMethod(interp, (XOTcl_Class *)cl, name, (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0, 0); +/* TODO move me at the right place */ +static int XOTclCSetterMethod(Tcl_Interp *interp, XOTclClass *cl, int withPer_object, char *name) { + if (withPer_object) { + return XOTclAddObjectMethod(interp, (XOTcl_Object*) cl, name, (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0, 0); + } else { + return XOTclAddInstanceMethod(interp, (XOTcl_Class *)cl, name, (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0, 0); + } } +static int XOTclOSetterMethod(Tcl_Interp *interp, XOTclObject *object, char *name) { + return XOTclAddObjectMethod(interp, (XOTcl_Object*) object, name, (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0, 0); +} + /* TODO move me at the right place */ static int XOTclOMethodMethod(Tcl_Interp *interp, XOTclObject *obj, int withInner_namespace, int withProtected, @@ -12102,19 +12255,28 @@ } } -static int XOTclCInstForwardMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *method, - 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 XOTclCForwardMethod(Tcl_Interp *interp, XOTclClass *cl, + int withPer_object, Tcl_Obj *method, + Tcl_Obj *withDefault, int withEarlybinding, Tcl_Obj *withMethodprefix, + int withObjscope, Tcl_Obj *withOnerror, int withVerbose, + Tcl_Obj *target, int nobjc, Tcl_Obj *CONST nobjv[]) { forwardCmdClientData *tcd; int result; result = forwardProcessOptions(interp, method, withDefault, withEarlybinding, withMethodprefix, withObjscope, withOnerror, withVerbose, target, nobjc, nobjv, &tcd); - if (result == TCL_OK) { + if (result != TCL_OK) { + return result; + } + if (withPer_object) { tcd->obj = &cl->object; + result = XOTclAddObjectMethod(interp, (XOTcl_Object *)cl, NSTail(ObjStr(method)), + (Tcl_ObjCmdProc*)XOTclForwardMethod, + (ClientData)tcd, forwardCmdDeleteProc, 0); + } else { + tcd->obj = &cl->object; result = XOTclAddInstanceMethod(interp, (XOTcl_Class*)cl, NSTail(ObjStr(method)), (Tcl_ObjCmdProc*)XOTclForwardMethod, (ClientData)tcd, forwardCmdDeleteProc, 0); @@ -12202,11 +12364,6 @@ TCL_OK; } -static int XOTclObjInfoBodyMethod(Tcl_Interp *interp, XOTclObject *object, char *methodName) { - Proc *proc = object->nsPtr ? FindProcMethod(object->nsPtr, methodName) : NULL; - return ListProcBody(interp, proc, methodName); -} - static int XOTclObjInfoCheckMethod(Tcl_Interp *interp, XOTclObject *object) { return AssertionListCheckOption(interp, object); } @@ -12220,10 +12377,6 @@ return TCL_OK; } -static int XOTclObjInfoCommandsMethod(Tcl_Interp *interp, XOTclObject *object, char *pattern) { - return ListKeys(interp, Tcl_Namespace_cmdTable(object->nsPtr), pattern); -} - static int XOTclObjInfoFilterMethod(Tcl_Interp *interp, XOTclObject *object, int withOrder, int withGuards, char *pattern) { XOTclObjectOpt *opt = object->opt; @@ -12293,6 +12446,22 @@ methodType, withNomixins, withIncontext); } +static int XOTclObjInfoMethodMethod(Tcl_Interp *interp, XOTclObject *object, + int withPer_object, int subcmd, + char *methodName) { + Tcl_Namespace *nsPtr; + if (XOTclObjectIsClass(object)) { + XOTclClass *class = (XOTclClass *)object; + nsPtr = withPer_object ? class->object.nsPtr : class->nsPtr; + } else { + nsPtr = object->nsPtr; + } + + return ListMethod(interp, object, + methodName, nsPtr ? FindMethod(nsPtr, methodName) : NULL, + subcmd, withPer_object); +} + static int XOTclObjInfoMixinMethod(Tcl_Interp *interp, XOTclObject *object, int withGuards, int withOrder, char *patternString, XOTclObject *patternObj) { if (withOrder) { @@ -12314,14 +12483,6 @@ methodName, withVarnames); } -static int XOTclObjInfoParametercmdMethod(Tcl_Interp *interp, XOTclObject *object, char *pattern) { - if (object->nsPtr) { - return ListMethodKeys(interp, Tcl_Namespace_cmdTable(object->nsPtr), pattern, - XOTCL_METHODTYPE_SETTER, NULL, NULL, 0); - } - return TCL_OK; -} - static int XOTclObjInfoParentMethod(Tcl_Interp *interp, XOTclObject *object) { if (object->id) { Tcl_SetResult(interp, NSCmdFullName(object->id), TCL_VOLATILE); @@ -12472,15 +12633,6 @@ return TCL_OK; } -static int XOTclClassInfoInstbodyMethod(Tcl_Interp *interp, XOTclClass *class, char * methodName) { - Proc *proc = FindProcMethod(class->nsPtr, methodName); - return ListProcBody(interp, proc, methodName); -} - -static int XOTclClassInfoInstcommandsMethod(Tcl_Interp *interp, XOTclClass * class, char * pattern) { - return ListKeys(interp, Tcl_Namespace_cmdTable(class->nsPtr), pattern); -} - static int XOTclClassInfoInstfilterMethod(Tcl_Interp *interp, XOTclClass * class, int withGuards, char * pattern) { return class->opt ? FilterInfo(interp, class->opt->instfilters, pattern, withGuards, 0) : TCL_OK; } @@ -12554,11 +12706,6 @@ return TCL_OK; } -static int XOTclClassInfoInstparametercmdMethod(Tcl_Interp *interp, XOTclClass * class, char * pattern) { - return ListMethodKeys(interp, Tcl_Namespace_cmdTable(class->nsPtr), pattern, - XOTCL_METHODTYPE_SETTER, NULL, NULL, 0); -} - static int XOTclClassInfoInstparamsMethod(Tcl_Interp *interp, XOTclClass *class, char *methodName, int withVarnames) { return ListCmdParams(interp, FindMethod(class->nsPtr, methodName), methodName, withVarnames); } Index: library/lib/pkgIndex.tcl =================================================================== diff -u -r217d826e64107056ae97176552cae3c776991b9e -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 --- library/lib/pkgIndex.tcl (.../pkgIndex.tcl) (revision 217d826e64107056ae97176552cae3c776991b9e) +++ library/lib/pkgIndex.tcl (.../pkgIndex.tcl) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) @@ -14,7 +14,7 @@ package ifneeded xotcl::mixinStrategy 0.9 [list source [file join $dir mixinStrategy.xotcl]] package ifneeded xotcl::script 0.9 [list source [file join $dir Script.xotcl]] package ifneeded xotcl::staticMetadataAnalyzer 0.84 [list source [file join $dir staticMetadata.xotcl]] -package ifneeded xotcl::test 1.38 [list source [file join $dir test.xotcl]] +package ifneeded xotcl::test 2.0 [list source [file join $dir test.xotcl]] package ifneeded xotcl::trace 0.91 [list source [file join $dir trace.xotcl]] package ifneeded xotcl::upvar-compat 1.0 [list source [file join $dir upvarcompat.xotcl]] package ifneeded xotcl::wafecompat 0.9 [list source [file join $dir wafecompat.tcl]] Index: library/lib/test.xotcl =================================================================== diff -u -r9f7fa883bf6ed48f1401f815caca1e34f56584a1 -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 --- library/lib/test.xotcl (.../test.xotcl) (revision 9f7fa883bf6ed48f1401f815caca1e34f56584a1) +++ library/lib/test.xotcl (.../test.xotcl) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) @@ -1,4 +1,4 @@ -package provide xotcl::test 1.38 +package provide xotcl::test 2.0 package require XOTcl namespace eval ::xotcl::test { Index: library/lib/xotcl1.xotcl =================================================================== diff -u -rf6be3f63eadda89d7f419a090d86669c6be84c3b -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 --- library/lib/xotcl1.xotcl (.../xotcl1.xotcl) (revision f6be3f63eadda89d7f419a090d86669c6be84c3b) +++ library/lib/xotcl1.xotcl (.../xotcl1.xotcl) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) @@ -93,21 +93,9 @@ Object create ::xotcl::objectInfo Object create ::xotcl::classInfo - 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 - } - ::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 - # note, we are using ::xotcl::infoError defined earlier - Object instforward info -onerror ::xotcl::infoError ::xotcl::objectInfo %1 {%@2 %self} - Class instforward info -onerror ::xotcl::infoError ::xotcl::classInfo %1 {%@2 %self} + Object forward info -onerror ::xotcl::infoError ::xotcl::objectInfo %1 {%@2 %self} + Class forward info -onerror ::xotcl::infoError ::xotcl::classInfo %1 {%@2 %self} objectInfo method info {obj} { set methods [list] @@ -135,6 +123,20 @@ error "[::xotcl::self] unknown info option \"$method\"; [.info info]" } + foreach cmd [::info command ::xotcl::cmd::ObjectInfo::*] { + set cmdName [namespace tail $cmd] + if {$cmdName eq "method"} continue + ::xotcl::alias ::xotcl::objectInfo $cmdName $cmd + ::xotcl::alias ::xotcl::classInfo $cmdName $cmd + } + foreach cmd [::info command ::xotcl::cmd::ClassInfo::*] { + ::xotcl::alias ::xotcl::classInfo [namespace tail $cmd] $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 + # # Backward compatibility info subcommands; # @@ -154,28 +156,38 @@ # info instnonposargs # info instdefault # - # => maybe instead of "info params" and "info instparams" - # info params ?-per-object? + # => maybe instead of "info params" and "info instparams" + # info params ?-per-object? # - # => TODO: use "params" in serializer, and all other occurances + # => info method .... replaces + # info body + # info instbody # - # TODO: not yet emulated: + # => info methods .... replaces + # info commands + # info instcommands + # info procs + # info instprocs + # info parametercmd + # info instparametercmd # - # => info is (bzw. ::xotcl::is) replaces - # isobject - # isclass - # ismetaclass - # ismixin - # istype + # => info is (resp. ::xotcl::is) replaces + # info isobject + # info isclass + # info ismetaclass + # info ismixin + # info istype # - # => method (should get pre- and postconditions via positional params) + # => method .... replaces # proc # instproc # + # => TODO: use "params" in serializer, and all other occurances + # + # # 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". + # TODO move unknown handler for Class into a library # proc ::xotcl::info_args {inst o method} { @@ -224,41 +236,44 @@ .method nonposargs {o method} {::xotcl::info_nonposargs "" $o $method} .method instdefault {o method arg var} {::xotcl::info_default inst $o $method $arg $var} .method default {o method arg var} {::xotcl::info_default "" $o $method $arg $var} - .method instprocs {o pattern:optional} { - if {[::info exists pattern]} { - ::xotcl::cmd::ObjectInfo::methods $o -defined -methodtype scripted $pattern - } { - ::xotcl::cmd::ObjectInfo::methods $o -defined -methodtype scripted - } + + # info options emulated by "info method" + .method instbody {o methodName} { + lindex [::xotcl::cmd::ObjectInfo::method $o definition $methodName] end } - .method procs {o pattern:optional} { - if {[::info exists pattern]} { - ::xotcl::cmd::ObjectInfo::methods $o -defined -per-object -methodtype scripted $pattern - } { - ::xotcl::cmd::ObjectInfo::methods $o -defined -per-object -methodtype scripted - } + + # info options emulated by "info methods" + .method instcommands {o {pattern:optional ""}} { + ::xotcl::cmd::ObjectInfo::methods $o -defined {*}$pattern } - .method parametercmd {o pattern:optional} { - if {[::info exists pattern]} { - ::xotcl::cmd::ObjectInfo::methods $o -defined -per-object -methodtype setter $pattern - } { - ::xotcl::cmd::ObjectInfo::methods $o -defined -per-object -methodtype setter - } + .method instprocs {o {pattern:optional ""}} { + ::xotcl::cmd::ObjectInfo::methods $o -defined -methodtype scripted {*}$pattern } + .method parametercmd {o {pattern:optional ""}} { + ::xotcl::cmd::ObjectInfo::methods $o -defined -per-object -methodtype setter {*}$pattern + } + .method instparametercmd {o {pattern:optional ""}} { + ::xotcl::cmd::ObjectInfo::methods $o -defined -methodtype setter {*}$pattern + } } objectInfo eval { .method args {o method} {::xotcl::info_args "" $o $method} .method nonposargs {o method} {::xotcl::info_nonposargs "" $o $method} .method default {o method arg var} {::xotcl::info_default "" $o $method $arg $var} - .method procs {o pattern:optional} { - if {[::info exists pattern]} { - ::xotcl::cmd::ObjectInfo::methods $o -defined -methodtype scripted $pattern - } { - ::xotcl::cmd::ObjectInfo::methods $o -defined -methodtype scripted - } + + # info options emulated by "info method" + .method body {o methodName} { + lindex [::xotcl::cmd::ObjectInfo::method $o -per-object definition $methodName] end } + # info options emulated by "info methods" + .method commands {o {pattern:optional ""}} { + ::xotcl::cmd::ObjectInfo::methods $o -defined -per-object {*}$pattern + } + .method procs {o {pattern:optional ""}} { + ::xotcl::cmd::ObjectInfo::methods $o -defined -per-object -methodtype scripted {*}$pattern + } .method methods { o -nocmds:switch -noprocs:switch -incontext:switch pattern:optional } { @@ -271,18 +286,22 @@ eval $cmd } } - # define methods on classInfo as well to overload the default behavior - ::xotcl::alias classInfo methods objectInfo::methods + # define info methods from objectInfo on classInfo as well + ::xotcl::alias classInfo body objectInfo::body + ::xotcl::alias classInfo commands objectInfo::commands + ::xotcl::alias classInfo methods objectInfo::methods + ::xotcl::alias classInfo procs objectInfo::procs - # emulation of isobject, ... + + # emulation of isobject, isclass ... 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::alias ::xotcl::Object contains ::xotcl::classes::xotcl2::Object::contains - ::xotcl::Class instforward slots %self 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 @@ -293,6 +312,7 @@ if {[info exists postcondition]} {lappend cmd -postcondition $postcondition} eval $cmd } + Object forward parametercmd %self setter 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} @@ -305,6 +325,16 @@ if {[info exists postcondition]} {lappend cmd -postcondition $postcondition} eval $cmd } + Class forward parametercmd %self setter -per-object + Class forward instparametercmd %self setter + + # we are changing the the semantics from forward -> instforward + ::xotcl::alias Class instforward ::xotcl::cmd::Class::forward + ::xotcl::alias Class forward ::xotcl::cmd::Object::forward + #Class method forward {name args} { + # ::xotcl::dispatch [self] ::xotcl::cmd::Class::forward -per-object $name {*}$args + #} + Object method abstract {methtype methname arglist} { if {$methtype ne "proc" && $methtype ne "instproc" && $methtype ne "method"} { error "invalid method type '$methtype', \ Index: tests/aliastest.xotcl =================================================================== diff -u -rf852fb6ccdfd85c86ae15f2a9ee84350e2d56dab -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 --- tests/aliastest.xotcl (.../aliastest.xotcl) (revision f852fb6ccdfd85c86ae15f2a9ee84350e2d56dab) +++ tests/aliastest.xotcl (.../aliastest.xotcl) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) @@ -18,6 +18,7 @@ # the system methods of Object are either alias or forwarders ? {lsort [::xotcl::Slot info methods -defined -methodtype alias]} {assign get} ? {::xotcl::Slot info alias -definition get} "::xotcl::setinstvar" +? {::xotcl::Slot info method definition get} "::xotcl::Slot alias get ::xotcl::setinstvar" ? {::xotcl::Object info alias -definition set} "-objscope ::set" Class create Base @@ -111,7 +112,7 @@ ? {lsort [T info methods -defined -per-object -methodtype alias]} {BAR FOO ZAP} ? {lsort [T info methods -per-object -defined -methodtype scripted]} {BAR FOO ZAP bar} ? {t foo} ::T->foo -? {T info alias -per-object -definition ZAP} {-per-object ::T::BAR} +? {T info alias -per-object -definition ZAP} {::T::BAR} ? {T FOO} ->foo ? {T BAR} ->foo Index: tests/destroytest.xotcl =================================================================== diff -u -rf6be3f63eadda89d7f419a090d86669c6be84c3b -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 --- tests/destroytest.xotcl (.../destroytest.xotcl) (revision f6be3f63eadda89d7f419a090d86669c6be84c3b) +++ tests/destroytest.xotcl (.../destroytest.xotcl) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) @@ -399,7 +399,7 @@ } C create ::C::c1 C::c1 foo -puts stderr ======[Object isobject ::C::c1] +#puts stderr ======[Object isobject ::C::c1] ? {Object isobject ::C::c1} 0 "$::case: object still exists after proc" ? {Object isclass ::C} 0 "$::case: class still exists after proc" ? "set ::firstDestroy" 1 "$::case, firstDestroy called" Index: tests/forwardtest.xotcl =================================================================== diff -u -r217d826e64107056ae97176552cae3c776991b9e -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 --- tests/forwardtest.xotcl (.../forwardtest.xotcl) (revision 217d826e64107056ae97176552cae3c776991b9e) +++ tests/forwardtest.xotcl (.../forwardtest.xotcl) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) @@ -67,10 +67,10 @@ ? {catch {obj Mixin}} 1 -obj forward Mixin -default {getter setter} mixin %1 %self +obj forward Mixin -default {Getter Setter} mixin %1 %self ? {obj Mixin add M1} [list ::mixin add ::obj M1] -? {obj Mixin M1} [list ::mixin setter ::obj M1] -? {obj Mixin} [list ::mixin getter ::obj] +? {obj Mixin M1} [list ::mixin Setter ::obj M1] +? {obj Mixin} [list ::mixin Getter ::obj] #puts "======" @@ -123,7 +123,7 @@ # check introspection for objects ? {lsort [obj info forward]} "Mixin addOne foo i1" -? {obj info forward -definition Mixin} "-default {getter setter} mixin %1 %self" +? {obj info forward -definition Mixin} "-default {Getter Setter} mixin %1 %self" ? {obj info forward -definition addOne} "expr 1 +" ? {obj info forward -definition foo} "target %proc %self %%self %%p" ? {obj info forward -definition i1} "-objscope ::incr x" Index: tests/protected.xotcl =================================================================== diff -u -r217d826e64107056ae97176552cae3c776991b9e -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 --- tests/protected.xotcl (.../protected.xotcl) (revision 217d826e64107056ae97176552cae3c776991b9e) +++ tests/protected.xotcl (.../protected.xotcl) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) @@ -1,5 +1,6 @@ -package require XOTcl; xotcl::use xotcl1 +package require XOTcl package require xotcl::test +xotcl::use xotcl2 set count 1 proc ? {cmd expected {msg ""}} { @@ -87,16 +88,16 @@ ? {catch {C method foo {a b c} {...}} errorMsg; set errorMsg} \ {Method 'foo' of ::C can not be overwritten. Derive e.g. a sub-class!} # check a predefined protection -? {catch {::xotcl::Class method dealloc {a b c} {...}} errorMsg; set errorMsg} \ - {Method 'dealloc' of ::xotcl::Class can not be overwritten. Derive e.g. a sub-class!} +? {catch {::xotcl2::Class method dealloc {a b c} {...}} errorMsg; set errorMsg} \ + {Method 'dealloc' of ::xotcl2::Class can not be overwritten. Derive e.g. a sub-class!} # try to redefined via alias ? {catch {::xotcl::alias Class dealloc ::set} errorMsg; set errorMsg} \ - {Method 'dealloc' of ::xotcl::Class can not be overwritten. Derive e.g. a sub-class!} + {Method 'dealloc' of ::xotcl2::Class can not be overwritten. Derive e.g. a sub-class!} # try to redefine via forward -? {catch {C instforward SET ::set} errorMsg; set errorMsg} \ +? {catch {C forward SET ::set} errorMsg; set errorMsg} \ {Method 'SET' of ::C can not be overwritten. Derive e.g. a sub-class!} -# try to redefine via forward -? {catch {C instparametercmd SET} errorMsg; set errorMsg} \ +# try to redefine via setter +? {catch {C setter SET} errorMsg; set errorMsg} \ {Method 'SET' of ::C can not be overwritten. Derive e.g. a sub-class!} # overwrite-protect object specific method Index: tests/testx.xotcl =================================================================== diff -u -rdb7c710aa3b6386c33af9a318876f21a88b8aafd -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 --- tests/testx.xotcl (.../testx.xotcl) (revision db7c710aa3b6386c33af9a318876f21a88b8aafd) +++ tests/testx.xotcl (.../testx.xotcl) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) @@ -138,17 +138,17 @@ Class C($i) C($i) invar { {$a > 2} {$c < 3} {$d > 5} - {#a} {#b} + {#a } {#b } } C($i) instinvar { {$a > 2} {$c < 3} {$d > 5} - {#a} {#b} + {#a } {#b } } - ::errorCheck [C($i) info invar] {{$a > 2} {$c < 3} {$d > 5} {#a} {#b}} \ + ::errorCheck [C($i) info invar] {{$a > 2} {$c < 3} {$d > 5} {#a } {#b }} \ "Class invar " - ::errorCheck [C($i) info invar] {{$a > 2} {$c < 3} {$d > 5} {#a} {#b}} \ + ::errorCheck [C($i) info invar] {{$a > 2} {$c < 3} {$d > 5} {#a } {#b }} \ "Class instinvar " Object b($i) @@ -157,24 +157,24 @@ {$a > 2} {$c < 3} {$d > 5} {#a} {#b} } - ::errorCheck [C($i) info invar] {{$a > 2} {$c < 3} {$d > 5} {#a} {#b}} \ + ::errorCheck [C($i) info invar] {{$a > 2} {$c < 3} {$d > 5} {#a } {#b }} \ "Object invar " b($i) proc p {a b c} { return p } {pre1 pre2 pre3} {post1 post2 post3} - ::errorCheck [b($i) info pre p] {{pre1} {pre2} {pre3}} \ + ::errorCheck [b($i) info pre p] {pre1 pre2 pre3} \ "Obj proc pre assertion " - ::errorCheck [b($i) info post p] {{post1} {post2} {post3}} \ + ::errorCheck [b($i) info post p] {post1 post2 post3} \ "Obj proc post assertion " C($i) instproc p {a b c} { return p } {} {post1 post2 post3} ::errorCheck [C($i) info instpre p] "" \ "CL proc pre assertion " - ::errorCheck [C($i) info instpost p] {{post1} {post2} {post3}} \ + ::errorCheck [C($i) info instpost p] {post1 post2 post3} \ "CL proc post assertion " C(0) set a 3; C(0) set c 2; C(0) set d 7; C(0) set f 50; @@ -201,9 +201,9 @@ return p } {pre1 pre2 pre3} {post1 post2 post3} ::rename b a - ::errorCheck [a info pre p] {{pre1} {pre2} {pre3}} \ + ::errorCheck [a info pre p] {pre1 pre2 pre3} \ "renamed Obj proc pre assertion " - ::errorCheck [a info post p] {{post1} {post2} {post3}} \ + ::errorCheck [a info post p] {post1 post2 post3} \ "renamed Obj proc post assertion " @@ -1736,7 +1736,14 @@ A create a0 a0 proc f3 {} {puts hu} a0 forward f4 puts hu + + puts stderr "### [Object self] info commands parametercmd => [Object info commands parametercmd]" + puts stderr a0->[a0 info class]-[A info class]-[::xotcl::Class info class]-[a0 info methods *parameter*] + puts stderr "### heritage: [a0 info precedence]" + a0 parametercmd f6 + puts stderr OK + ::errorCheck [a0 procsearch f1] "::A instproc f1" procsearch-1 ::errorCheck [a0 procsearch f2] "::A instforward f2" procsearch-2 ::errorCheck [a0 procsearch f3] "::a0 proc f3" procsearch-3 @@ -3094,11 +3101,11 @@ ::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 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 setter 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 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 procsearch requireNamespace residualargs set subst trace unset uplevel upvar volatile vwait" "b info methods -noprocs" + ::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 procsearch 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 self setFilter signature unknown" "b info methods -nocmds -nomixins" ::errorCheck [b info methods -nocmds -noprocs] "" "b info methods -nocmds -noprocs" @@ -3369,8 +3376,8 @@ ::errorCheck [e1 exists X] "1" "forward 3" ::errorCheck [e1 q] q "self proc" - ::errorCheck [E info commands] {p slot} "class commands" - ::errorCheck [E info instcommands] "t x q" "class instcommands" + ::errorCheck [lsort [E info commands]] {p slot} "class commands" + ::errorCheck [lsort [E info instcommands]] "q t x" "class instcommands" ::errorCheck [E info instbody t] "return ok" "class info instbody" Object o @@ -3493,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 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 setter 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 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 setter 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"