Index: generic/gentclAPI.decls =================================================================== diff -u -rf9e18344d59553044453d08e464acce46664ffcf -raef09781efb62a6336ecf355e927549d72b37a7a --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision f9e18344d59553044453d08e464acce46664ffcf) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision aef09781efb62a6336ecf355e927549d72b37a7a) @@ -134,6 +134,14 @@ objectMethod invar XOTclOInvariantsMethod { {-argName "invariantlist" -required 1 -type tclobj} } +objectMethod method XOTclOMethodMethod { + {-argName "-inner-namespace" -type switch} + {-argName "name" -required 1 -type tclobj} + {-argName "args" -required 1 -type tclobj} + {-argName "body" -required 1 -type tclobj} + {-argName "-precondition" -nrargs 1 -type tclobj} + {-argName "-postcondition" -nrargs 1 -type tclobj} +} objectMethod mixinguard XOTclOMixinGuardMethod { {-argName "mixin" -required 1} {-argName "guard" -required 1 -type tclobj} @@ -146,13 +154,6 @@ objectMethod parametercmd XOTclOParametercmdMethod { {-argName "name" -required 1} } -objectMethod proc XOTclOProcMethod { - {-argName "name" -required 1 -type tclobj} - {-argName "args" -required 1 -type tclobj} - {-argName "body" -required 1 -type tclobj} - {-argName "precondition" -type tclobj} - {-argName "postcondition" -type tclobj} -} objectMethod procsearch XOTclOProcSearchMethod { {-argName "name" -required 1} } @@ -209,12 +210,14 @@ classMethod instparametercmd XOTclCInstParametercmdMethod { {-argName "name" -required 1} } -classMethod instproc XOTclCInstProcMethod { +classMethod method XOTclCMethodMethod { + {-argName "-per-object" -type switch} + {-argName "-inner-namespace" -type switch} {-argName "name" -required 1 -type tclobj} {-argName "args" -required 1 -type tclobj} {-argName "body" -required 1 -type tclobj} - {-argName "precondition" -type tclobj} - {-argName "postcondition" -type tclobj} + {-argName "-precondition" -nrargs 1 -type tclobj} + {-argName "-postcondition" -nrargs 1 -type tclobj} } classMethod classscopedinstproc XOTclCInstProcMethodC { {-argName "name" -required 1 -type tclobj} Index: generic/gentclAPI.tcl =================================================================== diff -u -r2ce14fba0764a9fcbbe7cc2f582472526a58ddf0 -raef09781efb62a6336ecf355e927549d72b37a7a --- generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision 2ce14fba0764a9fcbbe7cc2f582472526a58ddf0) +++ generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision aef09781efb62a6336ecf355e927549d72b37a7a) @@ -44,6 +44,7 @@ switch -glob $type { "NULL" {set converter String} "boolean" {set converter Boolean} + "switch" {set converter Boolean} "class" {set converter Class} "object" {set converter Object} "tclobj" {set converter Tclobj} Index: generic/predefined.h =================================================================== diff -u -rf9e18344d59553044453d08e464acce46664ffcf -raef09781efb62a6336ecf355e927549d72b37a7a --- generic/predefined.h (.../predefined.h) (revision f9e18344d59553044453d08e464acce46664ffcf) +++ generic/predefined.h (.../predefined.h) (revision aef09781efb62a6336ecf355e927549d72b37a7a) @@ -14,8 +14,8 @@ "::xotcl::alias ::xotcl::Object $cmd -objscope ::$cmd}\n" "foreach cmd [info command ::xotcl::cmd::Class::*] {\n" "::xotcl::alias ::xotcl::Class [namespace tail $cmd] $cmd}\n" -"::xotcl::Object instproc init args {}\n" -"::xotcl::Object instproc objectparameter {} {;}\n" +"::xotcl::Object method init args {}\n" +"::xotcl::Object method objectparameter {} {;}\n" "::xotcl::Class create ::xotcl::ParameterType\n" "foreach cmd [info command ::xotcl::cmd::ParameterType::*] {\n" "::xotcl::alias ::xotcl::ParameterType [namespace tail $cmd] $cmd}\n" @@ -40,23 +40,23 @@ "regsub -all \" \" $msg \"\" msg\n" "regsub {\\\"} $msg \"\\\"info \" msg\n" "error $msg \"\"}\n" -"::xotcl::objectInfo proc info {obj} {\n" +"::xotcl::objectInfo method info {obj} {\n" "set methods [list]\n" "foreach m [::info commands ::xotcl::objectInfo::*] {\n" "set name [namespace tail $m]\n" "if {$name eq \"unknown\"} continue\n" "lappend methods $name}\n" "return \"valid options are: [join [lsort $methods] {, }]\"}\n" -"::xotcl::objectInfo proc unknown {method args} {\n" +"::xotcl::objectInfo method unknown {method args} {\n" "error \"unknown info option \\\"$method\\\"; [my info info]\"}\n" -"::xotcl::classInfo proc info {cl} {\n" +"::xotcl::classInfo method info {cl} {\n" "set methods [list]\n" "foreach m [::info commands ::xotcl::classInfo::*] {\n" "set name [namespace tail $m]\n" "if {$name eq \"unknown\"} continue\n" "lappend methods $name}\n" "return \"valid options are: [join [lsort $methods] {, }]\"}\n" -"::xotcl::classInfo proc unknown {method args} {\n" +"::xotcl::classInfo method unknown {method args} {\n" "error \"unknown info option \\\"$method\\\"; [my info info]\"}\n" "# info instargs\n" "# istype\n" @@ -86,34 +86,49 @@ "set default \"\"\n" "return 0}}\n" "error \"procedure \\\"$method\\\" doesn't have an argument \\\"$varName\\\"\"}\n" -"::xotcl::classInfo proc instargs {o method} {::xotcl::info_args inst $o $method}\n" -"::xotcl::classInfo proc args {o method} {::xotcl::info_args \"\" $o $method}\n" -"::xotcl::objectInfo proc args {o method} {::xotcl::info_args \"\" $o $method}\n" -"::xotcl::classInfo proc instnonposargs {o method} {::xotcl::info_nonposargs inst $o $method}\n" -"::xotcl::classInfo proc nonposargs {o method} {::xotcl::info_nonposargs \"\" $o $method}\n" -"::xotcl::objectInfo proc nonposargs {o method} {::xotcl::info_nonposargs \"\" $o $method}\n" -"::xotcl::classInfo proc instdefault {o method arg var} {::xotcl::info_default inst $o $method $arg $var}\n" -"::xotcl::classInfo proc default {o method arg var} {::xotcl::info_default \"\" $o $method $arg $var}\n" -"::xotcl::objectInfo proc default {o method arg var} {::xotcl::info_default \"\" $o $method $arg $var}\n" -"::xotcl::Object instproc isobject {{object:substdefault \"[self]\"}} {::xotcl::is $object object}\n" -"::xotcl::Object instproc isclass {{class:substdefault \"[self]\"}} {::xotcl::is $class class}\n" -"::xotcl::Object instproc ismetaclass {{class:substdefault \"[self]\"}} {::xotcl::is $class metaclass}\n" -"::xotcl::Object instproc ismixin {class} {::xotcl::is [self] mixin $class}\n" -"::xotcl::Object instproc istype {class} {::xotcl::is [self] type $class}\n" +"::xotcl::classInfo method instargs {o method} {::xotcl::info_args inst $o $method}\n" +"::xotcl::classInfo method args {o method} {::xotcl::info_args \"\" $o $method}\n" +"::xotcl::objectInfo method args {o method} {::xotcl::info_args \"\" $o $method}\n" +"::xotcl::classInfo method instnonposargs {o method} {::xotcl::info_nonposargs inst $o $method}\n" +"::xotcl::classInfo method nonposargs {o method} {::xotcl::info_nonposargs \"\" $o $method}\n" +"::xotcl::objectInfo method nonposargs {o method} {::xotcl::info_nonposargs \"\" $o $method}\n" +"::xotcl::classInfo method instdefault {o method arg var} {::xotcl::info_default inst $o $method $arg $var}\n" +"::xotcl::classInfo method default {o method arg var} {::xotcl::info_default \"\" $o $method $arg $var}\n" +"::xotcl::objectInfo method default {o method arg var} {::xotcl::info_default \"\" $o $method $arg $var}\n" +"::xotcl::Object method isobject {{object:substdefault \"[self]\"}} {::xotcl::is $object object}\n" +"::xotcl::Object method isclass {{class:substdefault \"[self]\"}} {::xotcl::is $class class}\n" +"::xotcl::Object method ismetaclass {{class:substdefault \"[self]\"}} {::xotcl::is $class metaclass}\n" +"::xotcl::Object method ismixin {class} {::xotcl::is [self] mixin $class}\n" +"::xotcl::Object method istype {class} {::xotcl::is [self] type $class}\n" +"::xotcl::Object method proc {name arglist body precondition:optional postcondition:optional} {\n" +"set cmd [list my method $name $arglist $body]\n" +"if {[info exists precondition]} {lappend cmd -precondition $precondition}\n" +"if {[info exists postcondition]} {lappend cmd -postcondition $postcondition}\n" +"eval $cmd}\n" +"::xotcl::Class method proc {name arglist body precondition:optional postcondition:optional} {\n" +"set cmd [list my method -per-object $name $arglist $body]\n" +"if {[info exists precondition]} {lappend cmd -precondition $precondition}\n" +"if {[info exists postcondition]} {lappend cmd -postcondition $postcondition}\n" +"eval $cmd}\n" +"::xotcl::Class method instproc {name arglist body precondition:optional postcondition:optional} {\n" +"set cmd [list my method $name $arglist $body]\n" +"if {[info exists precondition]} {lappend cmd -precondition $precondition}\n" +"if {[info exists postcondition]} {lappend cmd -postcondition $postcondition}\n" +"eval $cmd}\n" "::xotcl::Object create ::xotcl::@\n" -"::xotcl::@ proc unknown args {}\n" +"::xotcl::@ method unknown args {}\n" "proc ::xotcl::myproc {args} {linsert $args 0 [::xotcl::self]}\n" "proc ::xotcl::myvar {var} {::xotcl::my requireNamespace; return [::xotcl::self]::$var}\n" "namespace export Object Class @ myproc myvar Attribute\n" "::xotcl::Class create ::xotcl::MetaSlot\n" "::xotcl::relation ::xotcl::MetaSlot superclass ::xotcl::Class\n" -"::xotcl::MetaSlot instproc new args {\n" +"::xotcl::MetaSlot method new args {\n" "set slotobject [::xotcl::self callingobject]::slot\n" "if {![::xotcl::is $slotobject object]} {::xotcl::Object create $slotobject}\n" "eval next -childof $slotobject $args}\n" "::xotcl::MetaSlot create ::xotcl::Slot\n" "::xotcl::MetaSlot invalidateobjectparameter\n" -"::xotcl::Object instproc objectparameter {} {\n" +"::xotcl::Object method objectparameter {} {\n" "set parameterdefinitions [list]\n" "set slots [::xotcl::objectInfo slotobjects [self]]\n" "foreach slot $slots {\n" @@ -171,30 +186,30 @@ "type}\n" "::xotcl::alias ::xotcl::Slot get ::xotcl::setinstvar\n" "::xotcl::alias ::xotcl::Slot assign ::xotcl::setinstvar\n" -"::xotcl::Slot instproc add {obj prop value {pos 0}} {\n" +"::xotcl::Slot method add {obj prop value {pos 0}} {\n" "if {![::xotcl::my multivalued]} {\n" "error \"Property $prop of [::xotcl::my domain]->$obj ist not multivalued\"}\n" "if {[$obj exists $prop]} {\n" "$obj set $prop [linsert [$obj set $prop] $pos $value]} else {\n" "$obj set $prop [list $value]}}\n" -"::xotcl::Slot instproc delete {-nocomplain:switch obj prop value} {\n" +"::xotcl::Slot method delete {-nocomplain:switch obj prop value} {\n" "set old [$obj set $prop]\n" "set p [lsearch -glob $old $value]\n" "if {$p>-1} {$obj set $prop [lreplace $old $p $p]} else {\n" "error \"$value is not a $prop of $obj (valid are: $old)\"}}\n" -"::xotcl::Slot instproc unknown {method args} {\n" +"::xotcl::Slot method unknown {method args} {\n" "set methods [list]\n" "foreach m [::xotcl::my info methods] {\n" "if {[::xotcl::Object info methods $m] ne \"\"} continue\n" "if {[string match __* $m]} continue\n" "lappend methods $m}\n" "error \"Method '$method' unknown for slot [::xotcl::self]; valid are: {[lsort $methods]]}\"}\n" -"::xotcl::Slot instproc destroy {} {\n" +"::xotcl::Slot method destroy {} {\n" "::xotcl::instvar domain\n" "if {$domain ne \"\"} {\n" "$domain invalidateobjectparameter}\n" "next}\n" -"::xotcl::Slot instproc init {} {\n" +"::xotcl::Slot method init {} {\n" "::xotcl::instvar name domain manager per-object\n" "set forwarder [expr {${per-object} ? \"forward\" : \"instforward\"}]\n" "if {$domain eq \"\"} {\n" @@ -206,12 +221,12 @@ "{multivalued true}\n" "{elementtype ::xotcl::Class}}\n" "::xotcl::relation ::xotcl::InfoSlot superclass ::xotcl::Slot\n" -"::xotcl::InfoSlot instproc get {obj prop} {$obj info $prop}\n" -"::xotcl::InfoSlot instproc add {obj prop value {pos 0}} {\n" +"::xotcl::InfoSlot method get {obj prop} {$obj info $prop}\n" +"::xotcl::InfoSlot method add {obj prop value {pos 0}} {\n" "if {![::xotcl::my multivalued]} {\n" "error \"Property $prop of [::xotcl::my domain]->$obj ist not multivalued\"}\n" "$obj $prop [linsert [$obj info $prop] $pos $value]}\n" -"::xotcl::InfoSlot instproc delete {-nocomplain:switch obj prop value} {\n" +"::xotcl::InfoSlot method delete {-nocomplain:switch obj prop value} {\n" "set old [$obj info $prop]\n" "if {[string first * $value] > -1 || [string first \\[ $value] > -1} {\n" "if {[my elementtype] ne \"\" && ![string match ::* $value]} {\n" @@ -231,7 +246,7 @@ "::xotcl::relation ::xotcl::InterceptorSlot superclass ::xotcl::InfoSlot\n" "::xotcl::alias ::xotcl::InterceptorSlot set ::xotcl::relation ;# for backwards compatibility\n" "::xotcl::alias ::xotcl::InterceptorSlot assign ::xotcl::relation\n" -"::xotcl::InterceptorSlot instproc add {obj prop value {pos 0}} {\n" +"::xotcl::InterceptorSlot method add {obj prop value {pos 0}} {\n" "if {![::xotcl::my multivalued]} {\n" "error \"Property $prop of [::xotcl::my domain]->$obj ist not multivalued\"}\n" "$obj $prop [linsert [$obj info $prop -guards] $pos $value]}\n" @@ -257,14 +272,14 @@ "initcmd\n" "valuecmd\n" "valuechangedcmd}\n" -"::xotcl::Attribute instproc __default_from_cmd {obj cmd var sub op} {\n" +"::xotcl::Attribute method __default_from_cmd {obj cmd var sub op} {\n" "$obj trace remove variable $var $op [list [::xotcl::self] [::xotcl::self proc] $obj $cmd]\n" "$obj set $var [$obj eval $cmd]}\n" -"::xotcl::Attribute instproc __value_from_cmd {obj cmd var sub op} {\n" +"::xotcl::Attribute method __value_from_cmd {obj cmd var sub op} {\n" "$obj set $var [$obj eval $cmd]}\n" -"::xotcl::Attribute instproc __value_changed_cmd {obj cmd var sub op} {\n" +"::xotcl::Attribute method __value_changed_cmd {obj cmd var sub op} {\n" "eval $cmd}\n" -"::xotcl::Attribute instproc check_single_value {\n" +"::xotcl::Attribute method check_single_value {\n" "{-keep_old_value:boolean true}\n" "value predicate type obj var} {\n" "if {![expr $predicate]} {\n" @@ -273,11 +288,11 @@ "$obj unset -nocomplain $var}\n" "error \"'$value' is not of type $type\"}\n" "if {$keep_old_value} {$obj set __oldvalue($var) $value}}\n" -"::xotcl::Attribute instproc check_multiple_values {values predicate type obj var} {\n" +"::xotcl::Attribute method check_multiple_values {values predicate type obj var} {\n" "foreach value $values {\n" "::xotcl::my check_single_value -keep_old_value false $value $predicate $type $obj $var}\n" "$obj set __oldvalue($var) $value}\n" -"::xotcl::Attribute instproc mk_type_checker {} {\n" +"::xotcl::Attribute method mk_type_checker {} {\n" "set __initcmd \"\"\n" "if {[::xotcl::my exists type]} {\n" "::xotcl::my instvar type name\n" @@ -293,7 +308,7 @@ "append __initcmd [subst -nocommands {\n" "if {[::xotcl::my exists $name]} {::xotcl::my set __oldvalue($name) [::xotcl::my set $name]}\\n}]}\n" "return $__initcmd}\n" -"::xotcl::Attribute instproc init {} {\n" +"::xotcl::Attribute method init {} {\n" "::xotcl::my instvar domain name\n" "next ;# do first ordinary slot initialization\n" "set __initcmd \"\"\n" @@ -308,13 +323,13 @@ "if {$__initcmd ne \"\"} {\n" "my set initcmd $__initcmd}}\n" "::xotcl::Class create ::xotcl::Slot::Nocheck \\\n" -"-instproc check_single_value args {;} -instproc check_multiple_values args {;} \\\n" -"-instproc mk_type_checker args {return \"\"}\n" +"-method check_single_value args {;} -method check_multiple_values args {;} \\\n" +"-method mk_type_checker args {return \"\"}\n" "::xotcl::Class create ::xotcl::Slot::Optimizer \\\n" -"-instproc proc args {::xotcl::next; ::xotcl::my optimize} \\\n" -"-instproc forward args {::xotcl::next; ::xotcl::my optimize} \\\n" -"-instproc init args {::xotcl::next; ::xotcl::my optimize} \\\n" -"-instproc optimize {} {\n" +"-method proc args {::xotcl::next; ::xotcl::my optimize} \\\n" +"-method forward args {::xotcl::next; ::xotcl::my optimize} \\\n" +"-method init args {::xotcl::next; ::xotcl::my optimize} \\\n" +"-method optimize {} {\n" "if {[::xotcl::my multivalued]} return\n" "if {[::xotcl::my defaultmethods] ne {get assign}} return\n" "if {[::xotcl::my procsearch assign] ne \"::xotcl::Slot instcmd assign\"} return\n" @@ -326,13 +341,13 @@ "createBootstrapAttributeSlots ::xotcl::ScopedNew {\n" "{withclass ::xotcl::Object}\n" "inobject}\n" -"::xotcl::ScopedNew instproc init {} {\n" -"::xotcl::my instproc new {-childof args} {\n" +"::xotcl::ScopedNew method init {} {\n" +"::xotcl::my method new {-childof args} {\n" "[::xotcl::self class] instvar {inobject object} withclass\n" "if {![::xotcl::is $object object]} {\n" "$withclass create $object}\n" "eval ::xotcl::next -childof $object $args}}\n" -"::xotcl::Object instproc contains {\n" +"::xotcl::Object method contains {\n" "{-withnew:boolean true}\n" "-object\n" "{-class ::xotcl::Object}\n" @@ -349,7 +364,7 @@ "namespace eval $object $cmds}}\n" "::xotcl::Class instforward slots %self contains \\\n" "-object {%::xotcl::my subst [::xotcl::self]::slot}\n" -"::xotcl::Class instproc parameter arglist {\n" +"::xotcl::Class method parameter arglist {\n" "if {![::xotcl::is [::xotcl::self]::slot object]} {\n" "::xotcl::Object create [::xotcl::self]::slot}\n" "foreach arg $arglist {\n" @@ -392,33 +407,33 @@ "if {![info exists setter]} {set setter set}\n" "if {![info exists getter]} {set getter set}\n" "if {![info exists access]} {set access ::xotcl::my}\n" -"$cl instproc $name args \"\n" +"$cl method $name args \"\n" "if {\\[llength \\$args] == 0} {\n" "return \\[$access $getter $extra $name\\]} else {\n" "return \\[eval $access $setter $extra $name \\$args $defaultParam \\]}\"\n" "foreach instvar {extra defaultParam setter getter access} {\n" "$po unset -nocomplain $instvar}} else {\n" "::xotcl::my instparametercmd $name}}}\n" "[::xotcl::self]::slot set __parameter $arglist}\n" -"::xotcl::Object instproc self {} {::xotcl::self}\n" -"::xotcl::Object instproc defaultmethod {} {\n" +"::xotcl::Object method self {} {::xotcl::self}\n" +"::xotcl::Object method defaultmethod {} {\n" "return [::xotcl::self]}\n" -"::xotcl::Object instproc hasclass cl {\n" +"::xotcl::Object method hasclass cl {\n" "if {[::xotcl::is [self] mixin $cl]} {return 1}\n" "::xotcl::is [self] type $cl}\n" -"::xotcl::Class instproc allinstances {} {\n" +"::xotcl::Class method allinstances {} {\n" "return [::xotcl::my info instances -closure]}\n" -"::xotcl::Object proc unsetExitHandler {} {\n" -"::xotcl::Object proc __exitHandler {} {\n" +"::xotcl::Object method -per-object unsetExitHandler {} {\n" +"::xotcl::Object method -per-object __exitHandler {} {\n" ";}}\n" "::xotcl::Object unsetExitHandler\n" -"::xotcl::Object proc setExitHandler {newbody} {\n" -"::xotcl::Object proc __exitHandler {} $newbody}\n" -"::xotcl::Object proc getExitHandler {} {\n" +"::xotcl::Object method -per-object setExitHandler {newbody} {\n" +"::xotcl::Object method -per-object __exitHandler {} $newbody}\n" +"::xotcl::Object method -per-object getExitHandler {} {\n" "::xotcl::Object info body __exitHandler}\n" "proc ::xotcl::__exitHandler {} {\n" "::xotcl::Object __exitHandler}\n" -"::xotcl::Object instproc abstract {methtype methname arglist} {\n" +"::xotcl::Object method abstract {methtype methname arglist} {\n" "if {$methtype ne \"proc\" && $methtype ne \"instproc\" && $methtype ne \"method\"} {\n" "error \"invalid method type '$methtype', \\\n" "must be either 'proc', 'instproc' or 'method'.\"}\n" @@ -430,7 +445,7 @@ "{targetList \"\"}\n" "{dest \"\"}\n" "objLength}\n" -"::xotcl::Object::CopyHandler instproc makeTargetList t {\n" +"::xotcl::Object::CopyHandler method makeTargetList t {\n" "::xotcl::my lappend targetList $t\n" "if {[::xotcl::is $t object]} {\n" "if {[$t info hasnamespace]} {\n" @@ -441,13 +456,13 @@ "lappend children [namespace children $t]}}\n" "foreach c $children {\n" "::xotcl::my makeTargetList $c}}\n" -"::xotcl::Object::CopyHandler instproc copyNSVarsAndCmds {orig dest} {\n" +"::xotcl::Object::CopyHandler method copyNSVarsAndCmds {orig dest} {\n" "::xotcl::namespace_copyvars $orig $dest\n" "::xotcl::namespace_copycmds $orig $dest}\n" -"::xotcl::Object::CopyHandler instproc getDest origin {\n" +"::xotcl::Object::CopyHandler method getDest origin {\n" "set tail [string range $origin [::xotcl::my set objLength] end]\n" "return ::[string trimleft [::xotcl::my set dest]$tail :]}\n" -"::xotcl::Object::CopyHandler instproc copyTargets {} {\n" +"::xotcl::Object::CopyHandler method copyTargets {} {\n" "foreach origin [::xotcl::my set targetList] {\n" "set dest [::xotcl::my getDest $origin]\n" "if {[::xotcl::is $origin object]} {\n" @@ -489,15 +504,15 @@ "set newslot ${dest}::slot::[namespace tail $oldslot]\n" "if {[$oldslot domain] eq $origin} {$newslot domain $cl}\n" "if {[$oldslot manager] eq $oldslot} {$newslot manager $newslot}}}}}\n" -"::xotcl::Object::CopyHandler instproc copy {obj dest} {\n" +"::xotcl::Object::CopyHandler method copy {obj dest} {\n" "::xotcl::my set objLength [string length $obj]\n" "::xotcl::my set dest $dest\n" "::xotcl::my makeTargetList $obj\n" "::xotcl::my copyTargets}\n" -"::xotcl::Object instproc copy newName {\n" +"::xotcl::Object method copy newName {\n" "if {[string compare [string trimleft $newName :] [string trimleft [::xotcl::self] :]]} {\n" "[[::xotcl::self class]::CopyHandler new -volatile] copy [::xotcl::self] $newName}}\n" -"::xotcl::Object instproc move newName {\n" +"::xotcl::Object method move newName {\n" "if {[string trimleft $newName :] ne [string trimleft [::xotcl::self] :]} {\n" "if {$newName ne \"\"} {\n" "::xotcl::my copy $newName}\n" @@ -509,14 +524,14 @@ "$subclass superclass $scl}} }\n" "::xotcl::my destroy}}\n" "::xotcl::Object create ::xotcl::config\n" -"::xotcl::config proc load {obj file} {\n" +"::xotcl::config method load {obj file} {\n" "source $file\n" "foreach i [array names ::auto_index [list $obj *proc *]] {\n" "set type [lindex $i 1]\n" "set meth [lindex $i 2]\n" "if {[$obj info ${type}s $meth] == {}} {\n" "$obj $type $meth auto $::auto_index($i)}}}\n" -"::xotcl::config proc mkindex {meta dir args} {\n" +"::xotcl::config method mkindex {meta dir args} {\n" "set sp {[ ]+}\n" "set st {^[ ]*}\n" "set wd {([^ ;]+)}\n" @@ -566,7 +581,7 @@ "close $t\n" "cd $old\n" "return \"$oc objects, $mc methods\"}\n" -"::xotcl::Object instproc extractConfigureArg {al name {cutTheArg 0}} {\n" +"::xotcl::Object method extractConfigureArg {al name {cutTheArg 0}} {\n" "set value \"\"\n" "upvar $al argList\n" "set largs [llength $argList]\n" @@ -582,15 +597,15 @@ "set argList [lreplace $argList $startIndex [expr {$endIndex - 1}]]}\n" "return $value}\n" "::xotcl::Object create ::xotcl::rcs\n" -"::xotcl::rcs proc date string {\n" +"::xotcl::rcs method date string {\n" "lreplace [lreplace $string 0 0] end end}\n" -"::xotcl::rcs proc version string {\n" +"::xotcl::rcs method version string {\n" "lindex $string 2}\n" "if {![info exists ::env(HOME)]} {set ::env(HOME) /root}\n" "set ::xotcl::confdir ~/.xotcl\n" "set ::xotcl::logdir $::xotcl::confdir/log\n" -"::xotcl::Class proc __unknown name {}\n" -"::xotcl::Class instproc uses list {\n" +"::xotcl::Class method -per-object __unknown name {}\n" +"::xotcl::Class method uses list {\n" "foreach package $list {\n" "::xotcl::package import -into [::xotcl::self] $package\n" "puts stderr \"*** using ${package}::* in [::xotcl::self]\"}}\n" @@ -599,14 +614,14 @@ "{version 1.0}\n" "{autoexport {}}\n" "{export {}}}\n" -"::xotcl::package proc create {name args} {\n" +"::xotcl::package method -per-object create {name args} {\n" "set nq [namespace qualifiers $name]\n" "if {$nq ne \"\" && ![namespace exists $nq]} {Object create $nq}\n" "next}\n" -"::xotcl::package proc extend {name args} {\n" +"::xotcl::package method -per-object extend {name args} {\n" "my require $name\n" "eval $name configure $args}\n" -"::xotcl::package instproc contains script {\n" +"::xotcl::package method -per-object contains script {\n" "if {[my exists provide]} {\n" "package provide [my provide] [my version]} else {\n" "package provide [::xotcl::self] [::xotcl::my version]}\n" @@ -623,11 +638,11 @@ "-set component . \\\n" "-set verbose 0 \\\n" "-set packagecmd ::package\n" -"::xotcl::package proc unknown args {\n" +"::xotcl::package method -per-object unknown args {\n" "eval [my set packagecmd] $args}\n" -"::xotcl::package proc verbose value {\n" +"::xotcl::package method -per-object verbose value {\n" "my set verbose $value}\n" -"::xotcl::package proc present args {\n" +"::xotcl::package method -per-object present args {\n" "if {$::tcl_version<8.3} {\n" "my instvar loaded\n" "switch -exact -- [lindex $args 0] {\n" @@ -637,15 +652,15 @@ "return $loaded($pkg)} else {\n" "error \"not found\"}} else {\n" "eval [my set packagecmd] present $args}}\n" -"::xotcl::package proc import {{-into ::} pkg} {\n" +"::xotcl::package method -per-object import {{-into ::} pkg} {\n" "my require $pkg\n" "namespace eval $into [subst -nocommands {\n" "namespace import ${pkg}::*}]\n" "foreach e [$pkg export] {\n" "set nq [namespace qualifiers $e]\n" "if {$nq ne \"\"} {\n" "namespace eval $into$nq [list namespace import ${pkg}::$e]}}}\n" -"::xotcl::package proc require args {\n" +"::xotcl::package method -per-object require args {\n" "::xotcl::my instvar component verbose uses loaded\n" "set prevComponent $component\n" "if {[catch {set v [eval package present $args]} msg]} {\n" @@ -661,12 +676,6 @@ "set loaded($pkg) $v ;# loaded stuff needed for Tcl 8.0}}\n" "set component $prevComponent\n" "return $v}\n" -"::xotcl::Object instproc method {name arguments body} {\n" -"my proc name $arguments $body }\n" -"::xotcl::Class instproc method {-per-object:switch name arguments body} {\n" -"if {${per-object}} {\n" -"my proc $name $arguments $body} else {\n" -"my instproc $name $arguments $body}}\n" "proc ::xotcl::tmpdir {} {\n" "foreach e [list TMPDIR TEMP TMP] {\n" "if {[info exists ::env($e)] \\\n" Index: generic/predefined.xotcl =================================================================== diff -u -rf9e18344d59553044453d08e464acce46664ffcf -raef09781efb62a6336ecf355e927549d72b37a7a --- generic/predefined.xotcl (.../predefined.xotcl) (revision f9e18344d59553044453d08e464acce46664ffcf) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision aef09781efb62a6336ecf355e927549d72b37a7a) @@ -68,11 +68,11 @@ ::xotcl::alias ::xotcl::Class [namespace tail $cmd] $cmd } # "init" must exist on Object. per default it is empty. - ::xotcl::Object instproc init args {} + ::xotcl::Object method init args {} # provide a placeholder for the bootup process. The real definition # is based on slots, which are not available at this point. - ::xotcl::Object instproc objectparameter {} {;} + ::xotcl::Object method objectparameter {} {;} # # create class and object for nonpositional argument processing @@ -120,7 +120,7 @@ regsub {\"} $msg "\"info " msg error $msg "" } - ::xotcl::objectInfo proc info {obj} { + ::xotcl::objectInfo method info {obj} { set methods [list] foreach m [::info commands ::xotcl::objectInfo::*] { set name [namespace tail $m] @@ -129,11 +129,11 @@ } return "valid options are: [join [lsort $methods] {, }]" } - ::xotcl::objectInfo proc unknown {method args} { + ::xotcl::objectInfo method unknown {method args} { error "unknown info option \"$method\"; [my info info]" } - ::xotcl::classInfo proc info {cl} { + ::xotcl::classInfo method info {cl} { set methods [list] foreach m [::info commands ::xotcl::classInfo::*] { set name [namespace tail $m] @@ -142,7 +142,7 @@ } return "valid options are: [join [lsort $methods] {, }]" } - ::xotcl::classInfo proc unknown {method args} { + ::xotcl::classInfo method unknown {method args} { error "unknown info option \"$method\"; [my info info]" } @@ -228,30 +228,50 @@ error "procedure \"$method\" doesn't have an argument \"$varName\"" } - ::xotcl::classInfo proc instargs {o method} {::xotcl::info_args inst $o $method} - ::xotcl::classInfo proc args {o method} {::xotcl::info_args "" $o $method} - ::xotcl::objectInfo proc args {o method} {::xotcl::info_args "" $o $method} + ::xotcl::classInfo method instargs {o method} {::xotcl::info_args inst $o $method} + ::xotcl::classInfo method args {o method} {::xotcl::info_args "" $o $method} + ::xotcl::objectInfo method args {o method} {::xotcl::info_args "" $o $method} - ::xotcl::classInfo proc instnonposargs {o method} {::xotcl::info_nonposargs inst $o $method} - ::xotcl::classInfo proc nonposargs {o method} {::xotcl::info_nonposargs "" $o $method} - ::xotcl::objectInfo proc nonposargs {o method} {::xotcl::info_nonposargs "" $o $method} + ::xotcl::classInfo method instnonposargs {o method} {::xotcl::info_nonposargs inst $o $method} + ::xotcl::classInfo method nonposargs {o method} {::xotcl::info_nonposargs "" $o $method} + ::xotcl::objectInfo method nonposargs {o method} {::xotcl::info_nonposargs "" $o $method} - ::xotcl::classInfo proc instdefault {o method arg var} {::xotcl::info_default inst $o $method $arg $var} - ::xotcl::classInfo proc default {o method arg var} {::xotcl::info_default "" $o $method $arg $var} - ::xotcl::objectInfo proc default {o method arg var} {::xotcl::info_default "" $o $method $arg $var} + ::xotcl::classInfo method instdefault {o method arg var} {::xotcl::info_default inst $o $method $arg $var} + ::xotcl::classInfo method default {o method arg var} {::xotcl::info_default "" $o $method $arg $var} + ::xotcl::objectInfo method default {o method arg var} {::xotcl::info_default "" $o $method $arg $var} # emulation of isobject, ... - ::xotcl::Object instproc isobject {{object:substdefault "[self]"}} {::xotcl::is $object object} - ::xotcl::Object instproc isclass {{class:substdefault "[self]"}} {::xotcl::is $class class} - ::xotcl::Object instproc ismetaclass {{class:substdefault "[self]"}} {::xotcl::is $class metaclass} - ::xotcl::Object instproc ismixin {class} {::xotcl::is [self] mixin $class} - ::xotcl::Object instproc istype {class} {::xotcl::is [self] type $class} + ::xotcl::Object method isobject {{object:substdefault "[self]"}} {::xotcl::is $object object} + ::xotcl::Object method isclass {{class:substdefault "[self]"}} {::xotcl::is $class class} + ::xotcl::Object method ismetaclass {{class:substdefault "[self]"}} {::xotcl::is $class metaclass} + ::xotcl::Object method ismixin {class} {::xotcl::is [self] mixin $class} + ::xotcl::Object method istype {class} {::xotcl::is [self] type $class} + # + ::xotcl::Object method proc {name arglist body precondition:optional postcondition:optional} { + set cmd [list my method $name $arglist $body] + if {[info exists precondition]} {lappend cmd -precondition $precondition} + if {[info exists postcondition]} {lappend cmd -postcondition $postcondition} + eval $cmd + } + ::xotcl::Class method proc {name arglist body precondition:optional postcondition:optional} { + set cmd [list my method -per-object $name $arglist $body] + if {[info exists precondition]} {lappend cmd -precondition $precondition} + if {[info exists postcondition]} {lappend cmd -postcondition $postcondition} + eval $cmd + } + ::xotcl::Class method instproc {name arglist body precondition:optional postcondition:optional} { + set cmd [list my method $name $arglist $body] + if {[info exists precondition]} {lappend cmd -precondition $precondition} + if {[info exists postcondition]} {lappend cmd -postcondition $postcondition} + eval $cmd + } + # documentation stub object -> just ignore per default. # if xoDoc is loaded, documentation will be activated ::xotcl::Object create ::xotcl::@ - ::xotcl::@ proc unknown args {} + ::xotcl::@ method unknown args {} proc ::xotcl::myproc {args} {linsert $args 0 [::xotcl::self]} proc ::xotcl::myvar {var} {::xotcl::my requireNamespace; return [::xotcl::self]::$var} @@ -265,7 +285,7 @@ ::xotcl::Class create ::xotcl::MetaSlot ::xotcl::relation ::xotcl::MetaSlot superclass ::xotcl::Class - ::xotcl::MetaSlot instproc new args { + ::xotcl::MetaSlot method new args { set slotobject [::xotcl::self callingobject]::slot if {![::xotcl::is $slotobject object]} {::xotcl::Object create $slotobject} eval next -childof $slotobject $args @@ -285,7 +305,7 @@ # Provide the a slot based mechanism for building an object # configuration interface from slot definitions - ::xotcl::Object instproc objectparameter {} { + ::xotcl::Object method objectparameter {} { set parameterdefinitions [list] # don't call [my info slotobjects], since filters on [self] # modifying the result (such as in the regression test) will cause @@ -393,7 +413,7 @@ ::xotcl::alias ::xotcl::Slot get ::xotcl::setinstvar ::xotcl::alias ::xotcl::Slot assign ::xotcl::setinstvar - ::xotcl::Slot instproc add {obj prop value {pos 0}} { + ::xotcl::Slot method add {obj prop value {pos 0}} { if {![::xotcl::my multivalued]} { error "Property $prop of [::xotcl::my domain]->$obj ist not multivalued" } @@ -404,15 +424,15 @@ } #[::xotcl::my domain] invalidateobjectparameter ;# TODO maybe not needed here } - ::xotcl::Slot instproc delete {-nocomplain:switch obj prop value} { + ::xotcl::Slot method delete {-nocomplain:switch obj prop value} { set old [$obj set $prop] set p [lsearch -glob $old $value] if {$p>-1} {$obj set $prop [lreplace $old $p $p]} else { error "$value is not a $prop of $obj (valid are: $old)" } } - ::xotcl::Slot instproc unknown {method args} { + ::xotcl::Slot method unknown {method args} { set methods [list] foreach m [::xotcl::my info methods] { if {[::xotcl::Object info methods $m] ne ""} continue @@ -423,15 +443,15 @@ } # TODO crashes currently - ::xotcl::Slot instproc destroy {} { + ::xotcl::Slot method destroy {} { ::xotcl::instvar domain if {$domain ne ""} { $domain invalidateobjectparameter } next } - ::xotcl::Slot instproc init {} { + ::xotcl::Slot method init {} { ::xotcl::instvar name domain manager per-object #puts stderr "slot init [self] exists name? [info exists name] '$name'" set forwarder [expr {${per-object} ? "forward" : "instforward"}] @@ -456,14 +476,14 @@ {elementtype ::xotcl::Class} } ::xotcl::relation ::xotcl::InfoSlot superclass ::xotcl::Slot - ::xotcl::InfoSlot instproc get {obj prop} {$obj info $prop} - ::xotcl::InfoSlot instproc add {obj prop value {pos 0}} { + ::xotcl::InfoSlot method get {obj prop} {$obj info $prop} + ::xotcl::InfoSlot method add {obj prop value {pos 0}} { if {![::xotcl::my multivalued]} { error "Property $prop of [::xotcl::my domain]->$obj ist not multivalued" } $obj $prop [linsert [$obj info $prop] $pos $value] } - ::xotcl::InfoSlot instproc delete {-nocomplain:switch obj prop value} { + ::xotcl::InfoSlot method delete {-nocomplain:switch obj prop value} { set old [$obj info $prop] if {[string first * $value] > -1 || [string first \[ $value] > -1} { # string contains meta characters @@ -500,7 +520,7 @@ ::xotcl::alias ::xotcl::InterceptorSlot set ::xotcl::relation ;# for backwards compatibility ::xotcl::alias ::xotcl::InterceptorSlot assign ::xotcl::relation - ::xotcl::InterceptorSlot instproc add {obj prop value {pos 0}} { + ::xotcl::InterceptorSlot method add {obj prop value {pos 0}} { if {![::xotcl::my multivalued]} { error "Property $prop of [::xotcl::my domain]->$obj ist not multivalued" } @@ -547,21 +567,21 @@ valuechangedcmd } - ::xotcl::Attribute instproc __default_from_cmd {obj cmd var sub op} { + ::xotcl::Attribute method __default_from_cmd {obj cmd var sub op} { #puts "GETVAR [::xotcl::self proc] obj=$obj cmd=$cmd, var=$var, op=$op" $obj trace remove variable $var $op [list [::xotcl::self] [::xotcl::self proc] $obj $cmd] $obj set $var [$obj eval $cmd] } - ::xotcl::Attribute instproc __value_from_cmd {obj cmd var sub op} { + ::xotcl::Attribute method __value_from_cmd {obj cmd var sub op} { #puts "GETVAR [::xotcl::self proc] obj=$obj cmd=$cmd, var=$var, op=$op" $obj set $var [$obj eval $cmd] } - ::xotcl::Attribute instproc __value_changed_cmd {obj cmd var sub op} { + ::xotcl::Attribute method __value_changed_cmd {obj cmd var sub op} { # puts stderr "**************************" # puts "valuechanged obj=$obj cmd=$cmd, var=$var, op=$op, ...\n$obj exists $var -> [$obj set $var]" eval $cmd } - ::xotcl::Attribute instproc check_single_value { + ::xotcl::Attribute method check_single_value { {-keep_old_value:boolean true} value predicate type obj var } { @@ -578,13 +598,13 @@ #puts "+++ checking single value done" } - ::xotcl::Attribute instproc check_multiple_values {values predicate type obj var} { + ::xotcl::Attribute method check_multiple_values {values predicate type obj var} { foreach value $values { ::xotcl::my check_single_value -keep_old_value false $value $predicate $type $obj $var } $obj set __oldvalue($var) $value } - ::xotcl::Attribute instproc mk_type_checker {} { + ::xotcl::Attribute method mk_type_checker {} { set __initcmd "" if {[::xotcl::my exists type]} { ::xotcl::my instvar type name @@ -611,7 +631,7 @@ } return $__initcmd } - ::xotcl::Attribute instproc init {} { + ::xotcl::Attribute method init {} { ::xotcl::my instvar domain name next ;# do first ordinary slot initialization # there might be already default values registered on the class @@ -636,13 +656,13 @@ # mixin class for decativating all checks ::xotcl::Class create ::xotcl::Slot::Nocheck \ - -instproc check_single_value args {;} -instproc check_multiple_values args {;} \ - -instproc mk_type_checker args {return ""} + -method check_single_value args {;} -method check_multiple_values args {;} \ + -method mk_type_checker args {return ""} ::xotcl::Class create ::xotcl::Slot::Optimizer \ - -instproc proc args {::xotcl::next; ::xotcl::my optimize} \ - -instproc forward args {::xotcl::next; ::xotcl::my optimize} \ - -instproc init args {::xotcl::next; ::xotcl::my optimize} \ - -instproc optimize {} { + -method proc args {::xotcl::next; ::xotcl::my optimize} \ + -method forward args {::xotcl::next; ::xotcl::my optimize} \ + -method init args {::xotcl::next; ::xotcl::my optimize} \ + -method optimize {} { #puts stderr "slot optimizer for [::xotcl::my domain] calls invalidateobjectparameter" #[::xotcl::my domain] invalidateobjectparameter if {[::xotcl::my multivalued]} return @@ -667,8 +687,8 @@ inobject } - ::xotcl::ScopedNew instproc init {} { - ::xotcl::my instproc new {-childof args} { + ::xotcl::ScopedNew method init {} { + ::xotcl::my method new {-childof args} { [::xotcl::self class] instvar {inobject object} withclass if {![::xotcl::is $object object]} { $withclass create $object @@ -682,7 +702,7 @@ # nested object structures. Optionally, creating new objects # in the specified scope can be turned off. # - ::xotcl::Object instproc contains { + ::xotcl::Object method contains { {-withnew:boolean true} -object {-class ::xotcl::Object} @@ -706,7 +726,7 @@ # # define parameter for backward compatibility and convenience # - ::xotcl::Class instproc parameter arglist { + ::xotcl::Class method parameter arglist { if {![::xotcl::is [::xotcl::self]::slot object]} { ::xotcl::Object create [::xotcl::self]::slot } @@ -765,7 +785,7 @@ if {![info exists setter]} {set setter set} if {![info exists getter]} {set getter set} if {![info exists access]} {set access ::xotcl::my} - $cl instproc $name args " + $cl method $name args " if {\[llength \$args] == 0} { return \[$access $getter $extra $name\] } else { @@ -785,44 +805,44 @@ # # utilities # - ::xotcl::Object instproc self {} {::xotcl::self} - ::xotcl::Object instproc defaultmethod {} { + ::xotcl::Object method self {} {::xotcl::self} + ::xotcl::Object method defaultmethod {} { #if {"::" ne [::xotcl::my info parent] } { # [::xotcl::my info parent] __next #} return [::xotcl::self] } # support for XOTcl specific convenience routines - ::xotcl::Object instproc hasclass cl { + ::xotcl::Object method hasclass cl { if {[::xotcl::is [self] mixin $cl]} {return 1} ::xotcl::is [self] type $cl } - ::xotcl::Class instproc allinstances {} { + ::xotcl::Class method allinstances {} { # TODO: mark it deprecated return [::xotcl::my info instances -closure] } # Exit Handler - ::xotcl::Object proc unsetExitHandler {} { - ::xotcl::Object proc __exitHandler {} { + ::xotcl::Object method -per-object unsetExitHandler {} { + ::xotcl::Object method -per-object __exitHandler {} { # clients should append exit handlers to this proc body ; } } # pre-defined as empty method ::xotcl::Object unsetExitHandler - ::xotcl::Object proc setExitHandler {newbody} { - ::xotcl::Object proc __exitHandler {} $newbody + ::xotcl::Object method -per-object setExitHandler {newbody} { + ::xotcl::Object method -per-object __exitHandler {} $newbody } - ::xotcl::Object proc getExitHandler {} { + ::xotcl::Object method -per-object getExitHandler {} { ::xotcl::Object info body __exitHandler } # provide a global handler to avoid a proc on the global object. proc ::xotcl::__exitHandler {} { ::xotcl::Object __exitHandler } - ::xotcl::Object instproc abstract {methtype methname arglist} { + ::xotcl::Object method abstract {methtype methname arglist} { if {$methtype ne "proc" && $methtype ne "instproc" && $methtype ne "method"} { error "invalid method type '$methtype', \ must be either 'proc', 'instproc' or 'method'." @@ -844,7 +864,7 @@ } # targets are all namspaces and objs part-of the copied obj - ::xotcl::Object::CopyHandler instproc makeTargetList t { + ::xotcl::Object::CopyHandler method makeTargetList t { ::xotcl::my lappend targetList $t # if it is an object without namespace, it is a leaf if {[::xotcl::is $t object]} { @@ -871,18 +891,18 @@ } } - ::xotcl::Object::CopyHandler instproc copyNSVarsAndCmds {orig dest} { + ::xotcl::Object::CopyHandler method copyNSVarsAndCmds {orig dest} { ::xotcl::namespace_copyvars $orig $dest ::xotcl::namespace_copycmds $orig $dest } # construct destination obj name from old qualified ns name - ::xotcl::Object::CopyHandler instproc getDest origin { + ::xotcl::Object::CopyHandler method getDest origin { set tail [string range $origin [::xotcl::my set objLength] end] return ::[string trimleft [::xotcl::my set dest]$tail :] } - ::xotcl::Object::CopyHandler instproc copyTargets {} { + ::xotcl::Object::CopyHandler method copyTargets {} { #puts stderr "COPY will copy targetList = [::xotcl::my set targetList]" foreach origin [::xotcl::my set targetList] { set dest [::xotcl::my getDest $origin] @@ -950,7 +970,7 @@ } } - ::xotcl::Object::CopyHandler instproc copy {obj dest} { + ::xotcl::Object::CopyHandler method copy {obj dest} { #puts stderr "[::xotcl::self] copy <$obj> <$dest>" ::xotcl::my set objLength [string length $obj] ::xotcl::my set dest $dest @@ -959,16 +979,16 @@ } #Class create ::xotcl::NoInit - #::xotcl::NoInit instproc init args {;} + #::xotcl::NoInit method init args {;} - ::xotcl::Object instproc copy newName { + ::xotcl::Object method copy newName { if {[string compare [string trimleft $newName :] [string trimleft [::xotcl::self] :]]} { [[::xotcl::self class]::CopyHandler new -volatile] copy [::xotcl::self] $newName } } - ::xotcl::Object instproc move newName { + ::xotcl::Object method move newName { if {[string trimleft $newName :] ne [string trimleft [::xotcl::self] :]} { if {$newName ne ""} { ::xotcl::my copy $newName @@ -988,7 +1008,7 @@ } ::xotcl::Object create ::xotcl::config - ::xotcl::config proc load {obj file} { + ::xotcl::config method load {obj file} { source $file foreach i [array names ::auto_index [list $obj *proc *]] { set type [lindex $i 1] @@ -999,7 +1019,7 @@ } } - ::xotcl::config proc mkindex {meta dir args} { + ::xotcl::config method mkindex {meta dir args} { set sp {[ ]+} set st {^[ ]*} set wd {([^ ;]+)} @@ -1066,7 +1086,7 @@ # # if cutTheArg not 0, it cut from upvar argsList # - ::xotcl::Object instproc extractConfigureArg {al name {cutTheArg 0}} { + ::xotcl::Object method extractConfigureArg {al name {cutTheArg 0}} { set value "" upvar $al argList set largs [llength $argList] @@ -1088,10 +1108,10 @@ } ::xotcl::Object create ::xotcl::rcs - ::xotcl::rcs proc date string { + ::xotcl::rcs method date string { lreplace [lreplace $string 0 0] end end } - ::xotcl::rcs proc version string { + ::xotcl::rcs method version string { lindex $string 2 } @@ -1100,14 +1120,14 @@ set ::xotcl::confdir ~/.xotcl set ::xotcl::logdir $::xotcl::confdir/log - ::xotcl::Class proc __unknown name { + ::xotcl::Class method -per-object __unknown name { #unknown $name } # # package support # - ::xotcl::Class instproc uses list { + ::xotcl::Class method uses list { foreach package $list { ::xotcl::package import -into [::xotcl::self] $package puts stderr "*** using ${package}::* in [::xotcl::self]" @@ -1119,16 +1139,16 @@ {autoexport {}} {export {}} } - ::xotcl::package proc create {name args} { + ::xotcl::package method -per-object create {name args} { set nq [namespace qualifiers $name] if {$nq ne "" && ![namespace exists $nq]} {Object create $nq} next } - ::xotcl::package proc extend {name args} { + ::xotcl::package method -per-object extend {name args} { my require $name eval $name configure $args } - ::xotcl::package instproc contains script { + ::xotcl::package method -per-object contains script { if {[my exists provide]} { package provide [my provide] [my version] } else { @@ -1153,14 +1173,14 @@ -set verbose 0 \ -set packagecmd ::package - ::xotcl::package proc unknown args { + ::xotcl::package method -per-object unknown args { #puts stderr "unknown: package $args" eval [my set packagecmd] $args } - ::xotcl::package proc verbose value { + ::xotcl::package method -per-object verbose value { my set verbose $value } - ::xotcl::package proc present args { + ::xotcl::package method -per-object present args { if {$::tcl_version<8.3} { my instvar loaded switch -exact -- [lindex $args 0] { @@ -1176,7 +1196,7 @@ eval [my set packagecmd] present $args } } - ::xotcl::package proc import {{-into ::} pkg} { + ::xotcl::package method -per-object import {{-into ::} pkg} { my require $pkg namespace eval $into [subst -nocommands { #puts stderr "*** package import ${pkg}::* into [namespace current]" @@ -1190,7 +1210,7 @@ } } } - ::xotcl::package proc require args { + ::xotcl::package method -per-object require args { #puts "XOTCL package require $args, current=[namespace current]" ::xotcl::my instvar component verbose uses loaded set prevComponent $component @@ -1213,21 +1233,6 @@ return $v } - - # - # define method "method" - # - ::xotcl::Object instproc method {name arguments body} { - my proc name $arguments $body - } - ::xotcl::Class instproc method {-per-object:switch name arguments body} { - if {${per-object}} { - my proc $name $arguments $body - } else { - my instproc $name $arguments $body - } - } - # return temp directory proc ::xotcl::tmpdir {} { foreach e [list TMPDIR TEMP TMP] { Index: generic/tclAPI.h =================================================================== diff -u -rf9e18344d59553044453d08e464acce46664ffcf -raef09781efb62a6336ecf355e927549d72b37a7a --- generic/tclAPI.h (.../tclAPI.h) (revision f9e18344d59553044453d08e464acce46664ffcf) +++ generic/tclAPI.h (.../tclAPI.h) (revision aef09781efb62a6336ecf355e927549d72b37a7a) @@ -57,10 +57,10 @@ 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 XOTclCInstProcMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCInstProcMethodCStub(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 XOTclCUnknownMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -118,11 +118,11 @@ static int XOTclOForwardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOInstVarMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOInvariantsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclOMethodMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); 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 XOTclOProcMethodStub(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 XOTclOSetMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -157,10 +157,10 @@ 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 XOTclCInstProcMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *precondition, Tcl_Obj *postcondition); static int XOTclCInstProcMethodC(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *precondition, Tcl_Obj *postcondition); 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 withPer_object, int withInner_namespace, 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 XOTclCUnknownMethod(Tcl_Interp *interp, XOTclClass *cl, char *name, int objc, Tcl_Obj *CONST objv[]); @@ -218,11 +218,11 @@ static int XOTclOForwardMethod(Tcl_Interp *interp, XOTclObject *obj, 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 XOTclOInstVarMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); static int XOTclOInvariantsMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *invariantlist); +static int XOTclOMethodMethod(Tcl_Interp *interp, XOTclObject *obj, int withInner_namespace, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition); 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 XOTclOProcMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *precondition, Tcl_Obj *postcondition); static int XOTclOProcSearchMethod(Tcl_Interp *interp, XOTclObject *obj, char *name); static int XOTclORequireNamespaceMethod(Tcl_Interp *interp, XOTclObject *obj); static int XOTclOSetMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *var, Tcl_Obj *value); @@ -258,10 +258,10 @@ XOTclCInstForwardMethodIdx, XOTclCInstMixinGuardMethodIdx, XOTclCInstParametercmdMethodIdx, - XOTclCInstProcMethodIdx, XOTclCInstProcMethodCIdx, XOTclCInvalidateObjectParameterMethodIdx, XOTclCInvariantsMethodIdx, + XOTclCMethodMethodIdx, XOTclCNewMethodIdx, XOTclCRecreateMethodIdx, XOTclCUnknownMethodIdx, @@ -319,11 +319,11 @@ XOTclOForwardMethodIdx, XOTclOInstVarMethodIdx, XOTclOInvariantsMethodIdx, + XOTclOMethodMethodIdx, XOTclOMixinGuardMethodIdx, XOTclONextMethodIdx, XOTclONoinitMethodIdx, XOTclOParametercmdMethodIdx, - XOTclOProcMethodIdx, XOTclOProcSearchMethodIdx, XOTclORequireNamespaceMethodIdx, XOTclOSetMethodIdx, @@ -532,29 +532,6 @@ } static int -XOTclCInstProcMethodStub(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[XOTclCInstProcMethodIdx].paramDefs, - method_definitions[XOTclCInstProcMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - Tcl_Obj *name = (Tcl_Obj *)pc.clientData[0]; - Tcl_Obj *args = (Tcl_Obj *)pc.clientData[1]; - Tcl_Obj *body = (Tcl_Obj *)pc.clientData[2]; - Tcl_Obj *precondition = (Tcl_Obj *)pc.clientData[3]; - Tcl_Obj *postcondition = (Tcl_Obj *)pc.clientData[4]; - - parseContextRelease(&pc); - return XOTclCInstProcMethod(interp, cl, name, args, body, precondition, postcondition); - - } -} - -static int XOTclCInstProcMethodCStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; XOTclClass *cl = XOTclObjectToClass(clientData); @@ -616,6 +593,31 @@ } static int +XOTclCMethodMethodStub(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[XOTclCMethodMethodIdx].paramDefs, + method_definitions[XOTclCMethodMethodIdx].nrParameters, + &pc) != TCL_OK) { + return TCL_ERROR; + } else { + int withPer_object = (int )pc.clientData[0]; + int withInner_namespace = (int )pc.clientData[1]; + Tcl_Obj *name = (Tcl_Obj *)pc.clientData[2]; + Tcl_Obj *args = (Tcl_Obj *)pc.clientData[3]; + Tcl_Obj *body = (Tcl_Obj *)pc.clientData[4]; + Tcl_Obj *withPrecondition = (Tcl_Obj *)pc.clientData[5]; + Tcl_Obj *withPostcondition = (Tcl_Obj *)pc.clientData[6]; + + parseContextRelease(&pc); + return XOTclCMethodMethod(interp, cl, withPer_object, withInner_namespace, name, args, body, withPrecondition, withPostcondition); + + } +} + +static int XOTclCNewMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; XOTclClass *cl = XOTclObjectToClass(clientData); @@ -1788,6 +1790,30 @@ } static int +XOTclOMethodMethodStub(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[XOTclOMethodMethodIdx].paramDefs, + method_definitions[XOTclOMethodMethodIdx].nrParameters, + &pc) != TCL_OK) { + return TCL_ERROR; + } else { + int withInner_namespace = (int )pc.clientData[0]; + Tcl_Obj *name = (Tcl_Obj *)pc.clientData[1]; + Tcl_Obj *args = (Tcl_Obj *)pc.clientData[2]; + Tcl_Obj *body = (Tcl_Obj *)pc.clientData[3]; + Tcl_Obj *withPrecondition = (Tcl_Obj *)pc.clientData[4]; + Tcl_Obj *withPostcondition = (Tcl_Obj *)pc.clientData[5]; + + parseContextRelease(&pc); + return XOTclOMethodMethod(interp, obj, withInner_namespace, name, args, body, withPrecondition, withPostcondition); + + } +} + +static int XOTclOMixinGuardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; XOTclObject *obj = (XOTclObject *)clientData; @@ -1856,29 +1882,6 @@ } static int -XOTclOProcMethodStub(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[XOTclOProcMethodIdx].paramDefs, - method_definitions[XOTclOProcMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - Tcl_Obj *name = (Tcl_Obj *)pc.clientData[0]; - Tcl_Obj *args = (Tcl_Obj *)pc.clientData[1]; - Tcl_Obj *body = (Tcl_Obj *)pc.clientData[2]; - Tcl_Obj *precondition = (Tcl_Obj *)pc.clientData[3]; - Tcl_Obj *postcondition = (Tcl_Obj *)pc.clientData[4]; - - parseContextRelease(&pc); - return XOTclOProcMethod(interp, obj, name, args, body, precondition, postcondition); - - } -} - -static int XOTclOProcSearchMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; XOTclObject *obj = (XOTclObject *)clientData; @@ -2347,13 +2350,6 @@ {"::xotcl::cmd::Class::instparametercmd", XOTclCInstParametercmdMethodStub, 1, { {"name", 1, 0, convertToString}} }, -{"::xotcl::cmd::Class::instproc", XOTclCInstProcMethodStub, 5, { - {"name", 1, 0, convertToTclobj}, - {"args", 1, 0, convertToTclobj}, - {"body", 1, 0, convertToTclobj}, - {"precondition", 0, 0, convertToTclobj}, - {"postcondition", 0, 0, convertToTclobj}} -}, {"::xotcl::cmd::Class::classscopedinstproc", XOTclCInstProcMethodCStub, 5, { {"name", 1, 0, convertToTclobj}, {"args", 1, 0, convertToTclobj}, @@ -2367,6 +2363,15 @@ {"::xotcl::cmd::Class::instinvar", XOTclCInvariantsMethodStub, 1, { {"invariantlist", 1, 0, convertToTclobj}} }, +{"::xotcl::cmd::Class::method", XOTclCMethodMethodStub, 7, { + {"-per-object", 0, 0, convertToBoolean}, + {"-inner-namespace", 0, 0, convertToBoolean}, + {"name", 1, 0, convertToTclobj}, + {"args", 1, 0, convertToTclobj}, + {"body", 1, 0, convertToTclobj}, + {"-precondition", 0, 1, convertToTclobj}, + {"-postcondition", 0, 1, convertToTclobj}} +}, {"::xotcl::cmd::Class::new", XOTclCNewMethodStub, 2, { {"-childof", 0, 1, convertToObject}, {"args", 0, 0, convertToNothing}} @@ -2608,6 +2613,14 @@ {"::xotcl::cmd::Object::invar", XOTclOInvariantsMethodStub, 1, { {"invariantlist", 1, 0, convertToTclobj}} }, +{"::xotcl::cmd::Object::method", XOTclOMethodMethodStub, 6, { + {"-inner-namespace", 0, 0, convertToBoolean}, + {"name", 1, 0, convertToTclobj}, + {"args", 1, 0, convertToTclobj}, + {"body", 1, 0, convertToTclobj}, + {"-precondition", 0, 1, convertToTclobj}, + {"-postcondition", 0, 1, convertToTclobj}} +}, {"::xotcl::cmd::Object::mixinguard", XOTclOMixinGuardMethodStub, 2, { {"mixin", 1, 0, convertToString}, {"guard", 1, 0, convertToTclobj}} @@ -2621,13 +2634,6 @@ {"::xotcl::cmd::Object::parametercmd", XOTclOParametercmdMethodStub, 1, { {"name", 1, 0, convertToString}} }, -{"::xotcl::cmd::Object::proc", XOTclOProcMethodStub, 5, { - {"name", 1, 0, convertToTclobj}, - {"args", 1, 0, convertToTclobj}, - {"body", 1, 0, convertToTclobj}, - {"precondition", 0, 0, convertToTclobj}, - {"postcondition", 0, 0, convertToTclobj}} -}, {"::xotcl::cmd::Object::procsearch", XOTclOProcSearchMethodStub, 1, { {"name", 1, 0, convertToString}} }, Index: generic/xotcl.c =================================================================== diff -u -rf9e18344d59553044453d08e464acce46664ffcf -raef09781efb62a6336ecf355e927549d72b37a7a --- generic/xotcl.c (.../xotcl.c) (revision f9e18344d59553044453d08e464acce46664ffcf) +++ generic/xotcl.c (.../xotcl.c) (revision aef09781efb62a6336ecf355e927549d72b37a7a) @@ -5989,8 +5989,46 @@ return result; } -static int makeMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *nameObj, Tcl_Obj *args, Tcl_Obj *body, - Tcl_Obj *precondition, Tcl_Obj *postcondition, int clsns) { +static int +MakeObjectMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *name, + Tcl_Obj *args, Tcl_Obj *body, + Tcl_Obj *precondition, Tcl_Obj *postcondition, int clsns) { + char *argStr = ObjStr(args), *bdyStr = ObjStr(body), *nameStr = ObjStr(name); + int result; + + if (precondition && !postcondition) { + return XOTclVarErrMsg(interp, objectName(obj), " method '", nameStr, + "'; when specifying a precondition (", ObjStr(precondition), + ") a postcondition must be specified as well", + (char *) NULL); + } + + /* if both, args and body are empty strings, we delete the method */ + if (*argStr == 0 && *bdyStr == 0) { + result = XOTclRemovePMethod(interp, (XOTcl_Object *)obj, nameStr); + + } else { + XOTclAssertionStore *aStore = NULL; + if (precondition || postcondition) { + XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj); + if (!opt->assertions) + opt->assertions = AssertionCreateStore(); + aStore = opt->assertions; + } + requireObjNamespace(interp, obj); + result = MakeProc(obj->nsPtr, aStore, + interp, name, args, body, precondition, postcondition, + obj, clsns); + } + + /* could be a filter => recompute filter order */ + FilterComputeDefined(interp, obj); + return result; +} + +static int MakeClassMethod(Tcl_Interp *interp, XOTclClass *cl, + Tcl_Obj *nameObj, Tcl_Obj *args, Tcl_Obj *body, + Tcl_Obj *precondition, Tcl_Obj *postcondition, int clsns) { XOTclClassOpt *opt = cl->opt; int result = TCL_OK; char *argStr = ObjStr(args), *bdyStr = ObjStr(body), *nameStr = ObjStr(nameObj); @@ -10809,50 +10847,6 @@ return TCL_OK; } -static int XOTclOIsClassMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *class) { - XOTclObject *o; - Tcl_SetIntObj(Tcl_GetObjResult(interp), - (GetObjectFromObj(interp, class ? class : obj->cmdName, &o) == TCL_OK - && XOTclObjectIsClass(o) )); - return TCL_OK; -} - -static int XOTclOIsMetaClassMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *metaclass) { - XOTclObject *o; - if (GetObjectFromObj(interp, metaclass ? metaclass : obj->cmdName, &o) == TCL_OK - && XOTclObjectIsClass(o) - && IsMetaClass(interp, (XOTclClass*)o, 1)) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - } else { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - } - return TCL_OK; -} - -static int XOTclOIsMixinMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *class) { - XOTclClass *cl; - int success = 0; - - if (GetClassFromObj(interp, class, &cl, obj->cl) == TCL_OK) { - success = hasMixin(interp, obj, cl); - } - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), success); - return TCL_OK; -} - -static int XOTclOIsTypeMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *class) { - XOTclClass *cl; - int success = 0; - - if (obj->cl && GetClassFromObj(interp, class, &cl, obj->cl) == TCL_OK) { - success = isSubType(obj->cl, cl); - } - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), success); - return TCL_OK; -} - static int XOTclOMixinGuardMethod(Tcl_Interp *interp, XOTclObject *obj, char *mixin, Tcl_Obj *guard) { XOTclObjectOpt *opt = obj->opt; @@ -10900,42 +10894,6 @@ return TCL_OK; } -static int XOTclOProcMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *name, - Tcl_Obj *args, Tcl_Obj *body, - Tcl_Obj *precondition, Tcl_Obj *postcondition) { - char *argStr = ObjStr(args), *bdyStr = ObjStr(body), *nameStr = ObjStr(name); - int result; - - if (precondition && !postcondition) { - return XOTclVarErrMsg(interp, objectName(obj), " method '", nameStr, - "'; when specifying a precondition (", ObjStr(precondition), - ") a postcondition must be specified as well", - (char *) NULL); - } - - /* if both, args and body are empty strings, we delete the method */ - if (*argStr == 0 && *bdyStr == 0) { - result = XOTclRemovePMethod(interp, (XOTcl_Object *)obj, nameStr); - - } else { - XOTclAssertionStore *aStore = NULL; - if (precondition || postcondition) { - XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj); - if (!opt->assertions) - opt->assertions = AssertionCreateStore(); - aStore = opt->assertions; - } - requireObjNamespace(interp, obj); - result = MakeProc(obj->nsPtr, aStore, - interp, name, args, body, precondition, postcondition, - obj, 0); - } - - /* could be a filter => recompute filter order */ - FilterComputeDefined(interp, obj); - return result; -} - static int XOTclOProcSearchMethod(Tcl_Interp *interp, XOTclObject *obj, char *name) { XOTclClass *pcl = NULL; Tcl_Command cmd = ObjectFindMethod(interp, obj, name, &pcl); @@ -11417,17 +11375,33 @@ XOTclAddInstanceMethod(interp, (XOTcl_Class *)cl, name, (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0, 0); return TCL_OK; } - -static int XOTclCInstProcMethod(Tcl_Interp *interp, XOTclClass *cl, - Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, - Tcl_Obj *precondition, Tcl_Obj *postcondition) { - return makeMethod(interp, cl, name, args, body, precondition, postcondition, 0); +/* TODO move me at the right place */ +static int XOTclOMethodMethod(Tcl_Interp *interp, XOTclObject *obj, + int withInner_namespace, + Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, + Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition) { + return MakeObjectMethod(interp, obj, name, args, body, + withPrecondition, withPostcondition, + withInner_namespace); } +/* TODO move me at the right place */ +static int XOTclCMethodMethod(Tcl_Interp *interp, XOTclClass *cl, + int withPer_object, int withInner_namespace, + Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, + Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition) { + if (withPer_object) { + return MakeObjectMethod(interp, &cl->object, name, args, body, + withPrecondition, withPostcondition, withInner_namespace); + } else { + return MakeClassMethod(interp, cl, name, args, body, + withPrecondition, withPostcondition, withInner_namespace); + } +} static int XOTclCInstProcMethodC(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *precondition, Tcl_Obj *postcondition) { - return makeMethod(interp, cl, name, args, body, precondition, postcondition, 1); + return MakeClassMethod(interp, cl, name, args, body, precondition, postcondition, 1); } Index: tests/testx.xotcl =================================================================== diff -u -rf9e18344d59553044453d08e464acce46664ffcf -raef09781efb62a6336ecf355e927549d72b37a7a --- tests/testx.xotcl (.../testx.xotcl) (revision f9e18344d59553044453d08e464acce46664ffcf) +++ tests/testx.xotcl (.../testx.xotcl) (revision aef09781efb62a6336ecf355e927549d72b37a7a) @@ -387,7 +387,7 @@ SC($i) destroy } - ::errorCheck $::filterCount 1080 \ + ::errorCheck $::filterCount 1120 \ "Filter Test - Filter Count -- Got: $::filterCount" # @@ -3062,14 +3062,14 @@ ::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 self set setFilter setvalues signature subst trace 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 method move myProc myProc2 myProcMix1 myProcMix2 objectparameter objproc self setFilter signature" "b info methods -nocmds" + ::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" "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 mixin mixinguard noinit parametercmd proc procsearch requireNamespace set setvalues subst trace unset uplevel upvar volatile vwait" "b info methods -noprocs" - ::errorCheck [lsort [b info methods -nocmds -nomixins]] "abstract contains copy defaultmethod extractConfigureArg f hasclass init isclass ismetaclass ismixin isobject istype method move myProc myProc2 objectparameter objproc self setFilter signature" "b info methods -nocmds -nomixins" + ::errorCheck [lsort [b info methods -noprocs]] "__next append array autoname check class cleanup configure destroy eval exists filter filterguard filtersearch forward incr info instvar invar lappend method mixin mixinguard noinit parametercmd procsearch requireNamespace set setvalues 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" "b info methods -nocmds -nomixins" ::errorCheck [b info methods -nocmds -noprocs] "" "b info methods -nocmds -noprocs" - ::errorCheck [lsort [B info methods -nocmds]] "abstract allinstances contains copy defaultmethod extractConfigureArg f hasclass init isclass ismetaclass ismixin isobject istype method move objectparameter parameter self setFilter signature uses" "B info methods -nocmds" + ::errorCheck [lsort [B info methods -nocmds]] "abstract allinstances contains copy defaultmethod extractConfigureArg f hasclass init instproc isclass ismetaclass ismixin isobject istype move objectparameter parameter proc self setFilter signature uses" "B info methods -nocmds" namespace eval a { proc o args {return o}