Index: generic/predefined.h =================================================================== diff -u -r05f4b42f7615ea410b7ac33093f5b8382ce7e8c5 -r48d5751e9aeb6a4f388f6531a9248c1847b22cae --- generic/predefined.h (.../predefined.h) (revision 05f4b42f7615ea410b7ac33093f5b8382ce7e8c5) +++ generic/predefined.h (.../predefined.h) (revision 48d5751e9aeb6a4f388f6531a9248c1847b22cae) @@ -146,40 +146,39 @@ "::xotcl2::Class create ::xotcl::MetaSlot\n" "::xotcl::relation ::xotcl::MetaSlot superclass ::xotcl2::Class\n" "::xotcl::MetaSlot create ::xotcl::Slot\n" +"::xotcl::MetaSlot create ::xotcl::ObjectParameterSlot\n" +"::xotcl::relation ::xotcl::ObjectParameterSlot superclass ::xotcl::Slot\n" "::xotcl::MetaSlot __invalidateobjectparameter\n" -"proc ::xotcl::parameterFromSlot {slot name} {\n" +"::xotcl::ObjectParameterSlot method toParameterSyntax {name} {\n" "set objparamdefinition $name\n" "set methodparamdefinition \"\"\n" "set objopts [list]\n" "set methodopts [list]\n" -"if {[$slot exists required] && [$slot required]} {\n" +"if {[info exists :required] && ${:required}} {\n" "lappend objopts required\n" "lappend methodopts required}\n" -"if {[$slot exists type]} {\n" -"set type [$slot type]\n" -"if {[string match ::* $type]} {\n" -"lappend objopts object type=$type\n" -"lappend methodopts object type=$type} else {\n" -"lappend objopts $type\n" -"lappend methodopts $type}}\n" -"if {[$slot exists multivalued] && [$slot multivalued]} {\n" -"if {!([$slot exists type] && [$slot type] eq \"relation\")} {\n" +"if {[info exists :type]} {\n" +"if {[string match ::* ${:type}]} {\n" +"lappend objopts object type=${:type}\n" +"lappend methodopts object type=${:type}} else {\n" +"lappend objopts ${:type}\n" +"lappend methodopts ${:type}}}\n" +"if {[info exists :multivalued] && ${:multivalued}} {\n" +"if {!([info exists :type] && ${:type} eq \"relation\")} {\n" "lappend objopts multivalued} else {}}\n" -"if {[$slot exists arg]} {\n" -"lappend objopts arg=[$slot arg]\n" -"lappend methodopts arg=[$slot arg]}\n" -"if {[$slot exists default]} {\n" -"set arg [::xotcl::setinstvar $slot default]\n" +"if {[info exists :arg]} {\n" +"lappend objopts arg=${:arg}\n" +"lappend methodopts arg=${:arg}}\n" +"if {[info exists :default]} {\n" +"set arg ${:default}\n" "if {[string match {*\\[*\\]*} $arg]} {\n" -"lappend objopts substdefault}} elseif {[$slot exists initcmd]} {\n" -"set arg [::xotcl::setinstvar $slot initcmd]\n" +"lappend objopts substdefault}} elseif {[info exists :initcmd]} {\n" +"set arg ${:initcmd}\n" "lappend objopts initcmd}\n" -"if {[$slot exists methodname]} {\n" -"set methodname [$slot methodname]\n" -"set slotname [$slot name]\n" -"if {$methodname ne $slotname} {\n" -"lappend objopts arg=$methodname\n" -"lappend methodopts arg=$methodname}}\n" +"if {[info exists :methodname]} {\n" +"if {${:methodname} ne ${:name}} {\n" +"lappend objopts arg=${:methodname}\n" +"lappend methodopts arg=${:methodname}}}\n" "if {[llength $objopts] > 0} {\n" "append objparamdefinition :[join $objopts ,]}\n" "if {[llength $methodopts] > 0} {\n" @@ -189,12 +188,11 @@ "return [list oparam $objparamdefinition mparam $methodparamdefinition]}\n" "proc ::xotcl::parametersFromSlots {obj} {\n" "set parameterdefinitions [list]\n" -"set slots [::xotcl2::objectInfo slotobjects $obj]\n" -"foreach slot $slots {\n" +"foreach slot [::xotcl2::objectInfo slotobjects $obj] {\n" "if {[::xotcl::is $obj type ::xotcl::Object] &&\n" "([$slot name] eq \"mixin\" || [$slot name] eq \"filter\")} continue\n" "set name [namespace tail $slot]\n" -"array set \"\" [::xotcl::parameterFromSlot $slot $name]\n" +"array set \"\" [$slot toParameterSyntax $name]\n" "lappend parameterdefinitions -$(oparam)}\n" "return $parameterdefinitions}\n" "::xotcl2::Object protected method objectparameter {} {\n" @@ -207,6 +205,7 @@ "arg:initcmd,optional\n" "return $parameterdefinitions}\n" "::xotcl::MetaSlot create ::xotcl::MethodParameterSlot\n" +"::xotcl::relation ::xotcl::MethodParameterSlot superclass ::xotcl::Slot\n" "foreach cmd [info command ::xotcl::cmd::MethodParameterSlot::*] {\n" "::xotcl::alias ::xotcl::MethodParameterSlot [namespace tail $cmd] $cmd}\n" "::xotcl::MethodParameterSlot create ::xotcl::methodParameterSlot\n" @@ -215,7 +214,7 @@ "::xotcl2::Object create ${class}::slot}\n" "foreach att $definitions {\n" "if {[llength $att]>1} {foreach {att default} $att break}\n" -"::xotcl::Slot create ${class}::slot::$att\n" +"::xotcl::ObjectParameterSlot create ${class}::slot::$att\n" "if {[info exists default]} {\n" "::xotcl::setinstvar ${class}::slot::$att default $default\n" "unset default}\n" @@ -231,42 +230,43 @@ "unset default}}\n" "$class __invalidateobjectparameter}\n" "createBootstrapAttributeSlots ::xotcl::Slot {\n" +"{name}\n" +"{multivalued false}\n" +"{required false}\n" +"default\n" +"type}\n" +"createBootstrapAttributeSlots ::xotcl::ObjectParameterSlot {\n" "{name \"[namespace tail [::xotcl::self]]\"}\n" "{methodname}\n" "{domain \"[lindex [regexp -inline {^(.*)::slot::[^:]+$} [::xotcl::self]] 1]\"}\n" "{defaultmethods {get assign}}\n" "{manager \"[::xotcl::self]\"}\n" -"{multivalued false}\n" -"{per-object false}\n" -"{forward-per-object}\n" -"{required false}\n" -"default\n" -"type}\n" -"::xotcl::alias ::xotcl::Slot get ::xotcl::setinstvar\n" -"::xotcl::alias ::xotcl::Slot assign ::xotcl::setinstvar\n" -"::xotcl::Slot public method add {obj prop value {pos 0}} {\n" +"{per-object false}}\n" +"::xotcl::alias ::xotcl::ObjectParameterSlot get ::xotcl::setinstvar\n" +"::xotcl::alias ::xotcl::ObjectParameterSlot assign ::xotcl::setinstvar\n" +"::xotcl::ObjectParameterSlot public method add {obj prop value {pos 0}} {\n" "if {![set :multivalued]} {\n" "error \"Property $prop of [set :domain]->$obj ist not multivalued\"}\n" "if {[$obj exists $prop]} {\n" "::xotcl::setinstvar $obj $prop [linsert [::xotcl::setinstvar $obj $prop] $pos $value]} else {\n" "::xotcl::setinstvar $obj $prop [list $value]}}\n" -"::xotcl::Slot public method delete {-nocomplain:switch obj prop value} {\n" +"::xotcl::ObjectParameterSlot public method delete {-nocomplain:switch obj prop value} {\n" "set old [::xotcl::setinstvar $obj $prop]\n" "set p [lsearch -glob $old $value]\n" "if {$p>-1} {::xotcl::setinstvar $obj $prop [lreplace $old $p $p]} else {\n" "error \"$value is not a $prop of $obj (valid are: $old)\"}}\n" -"::xotcl::Slot method unknown {method args} {\n" +"::xotcl::ObjectParameterSlot method unknown {method args} {\n" "set methods [list]\n" "foreach m [:info callable] {\n" "if {[::xotcl2::Object info callable $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 public method destroy {} {\n" +"::xotcl::ObjectParameterSlot public method destroy {} {\n" "if {${:domain} ne \"\" && [::xotcl::is ${:domain} object]} {\n" "${:domain} __invalidateobjectparameter}\n" "next}\n" -"::xotcl::Slot method init {args} {\n" +"::xotcl::ObjectParameterSlot protected method init {args} {\n" "if {${:domain} eq \"\"} {\n" "set :domain [::xotcl::self callingobject]}\n" "if {${:domain} ne \"\"} {\n" @@ -283,7 +283,7 @@ "{multivalued true}\n" "{type relation}\n" "{elementtype ::xotcl2::Class}}\n" -"::xotcl::relation ::xotcl::RelationSlot superclass ::xotcl::Slot\n" +"::xotcl::relation ::xotcl::RelationSlot superclass ::xotcl::ObjectParameterSlot\n" "::xotcl::alias ::xotcl::RelationSlot assign ::xotcl::relation\n" "::xotcl::RelationSlot protected method init {} {\n" "if {${:type} ne \"relation\"} {\n" @@ -322,26 +322,44 @@ "::xotcl::alias ${os}::Class::slot::superclass assign ::xotcl::relation\n" "::xotcl::RelationSlot create ${os}::Object::slot::class -multivalued false\n" "::xotcl::alias ${os}::Object::slot::class assign ::xotcl::relation\n" -"::xotcl::RelationSlot create ${os}::Object::slot::mixin \\\n" -"-methodname object-mixin\n" -"::xotcl::RelationSlot create ${os}::Object::slot::filter \\\n" -"-elementtype \"\"\n" -"::xotcl::RelationSlot create ${os}::Class::slot::mixin \\\n" -"-methodname class-mixin\n" -"::xotcl::RelationSlot create ${os}::Class::slot::filter \\\n" +"::xotcl::RelationSlot create ${os}::Object::slot::mixin -methodname object-mixin\n" +"::xotcl::RelationSlot create ${os}::Object::slot::filter -elementtype \"\"\n" +"::xotcl::RelationSlot create ${os}::Class::slot::mixin -methodname class-mixin\n" +"::xotcl::RelationSlot create ${os}::Class::slot::filter -elementtype \"\" \\\n" "-methodname filter-mixin\n" "::xotcl::RelationSlot create ${os}::Class::slot::object-mixin\n" -"::xotcl::RelationSlot create ${os}::Class::slot::object-filter \\\n" -"-elementtype \"\"}\n" +"::xotcl::RelationSlot create ${os}::Class::slot::object-filter -elementtype \"\"}\n" "::xotcl::register_system_slots ::xotcl2\n" +"proc ::xotcl::register_system_slots {} {}\n" "::xotcl::MetaSlot __invalidateobjectparameter\n" -"::xotcl::MetaSlot create ::xotcl::Attribute -superclass ::xotcl::Slot\n" +"::xotcl::MetaSlot create ::xotcl::Attribute -superclass ::xotcl::ObjectParameterSlot\n" "createBootstrapAttributeSlots ::xotcl::Attribute {\n" "{value_check once}\n" "initcmd\n" "valuecmd\n" "valuechangedcmd\n" "arg}\n" +"::xotcl::Attribute object method createFromParameterSyntax {target value default:optional} {\n" +"set opts [list]\n" +"set colonPos [string first : $value]\n" +"if {$colonPos == -1} {\n" +"set name $value} else {\n" +"set properties [string range $value [expr {$colonPos+1}] end]\n" +"set name [string range $value 0 [expr {$colonPos -1}]]\n" +"foreach property [split $properties ,] {\n" +"if {$property eq \"required\"} {\n" +"lappend opts -required 1} elseif {$property eq \"multivalued\"} {\n" +"lappend opts -multivalued 1} elseif {[string match type=* $property]} {\n" +"set type [string range $property 5 end]\n" +"if {![string match ::* $type]} {set type ::$type}} elseif {[string match arg=* $property]} {\n" +"set argument [string range $property 4 end]\n" +"lappend opts -arg $argument} else {\n" +"set type $property}}}\n" +"if {[info exists type]} {\n" +"lappend opts -type $type}\n" +"if {[info exists default]} {\n" +"lappend opts -default $default}\n" +"::xotcl::Attribute create ${target}::slot::$name {*}$opts}\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" "::xotcl::setinstvar $obj $var [$obj eval $cmd]}\n" @@ -375,15 +393,15 @@ "append __initcmd [subst -nocommands {\n" "if {[:exists ${:name}]} {set :__oldvalue(${:name}) [set :${:name}]}\\n}]}\n" "return $__initcmd}\n" -"::xotcl::Attribute method init {} {\n" +"::xotcl::Attribute protected method init {} {\n" "next ;# do first ordinary slot initialization\n" "set __initcmd \"\"\n" "if {[:exists default]} {} elseif [:exists initcmd] {\n" "append __initcmd \":trace add variable [list ${:name}] read \\\n" "\\[list [::xotcl::self] __default_from_cmd \\[::xotcl::self\\] [list [set :initcmd]]\\]\\n\"} elseif [:exists valuecmd] {\n" "append __initcmd \":trace add variable [list ${:name}] read \\\n" "\\[list [::xotcl::self] __value_from_cmd \\[::xotcl::self\\] [list [set :valuecmd]]\\]\"}\n" -"array set \"\" [::xotcl::parameterFromSlot [self] \"value\"]\n" +"array set \"\" [:toParameterSyntax \"value\"]\n" "if {$(mparam) ne \"\"} {\n" "if {[info exists :multivalued] && ${:multivalued}} {\n" ":method assign [list obj var value:$(mparam),multivalued] {::xotcl::setinstvar $obj $var $value}\n" @@ -394,83 +412,32 @@ "\\[list [::xotcl::self] __value_changed_cmd \\[::xotcl::self\\] [list [set :valuechangedcmd]]\\]\"}\n" "if {$__initcmd ne \"\"} {\n" "set :initcmd $__initcmd}}\n" -"::xotcl2::Class create ::xotcl::Slot::Nocheck {\n" +"::xotcl2::Class create ::xotcl::ObjectParameterSlot::Nocheck {\n" ":method check_single_value args {;}\n" ":method check_multiple_values args {;}\n" ":method mk_type_checker args {return \"\"}}\n" -"::xotcl2::Class create ::xotcl::Slot::Optimizer {\n" +"::xotcl2::Class create ::xotcl::ObjectParameterSlot::Optimizer {\n" ":method method args {::xotcl::next; :optimize}\n" ":method forward args {::xotcl::next; :optimize}\n" -":method init args {::xotcl::next; :optimize}\n" +":protected method init args {::xotcl::next; :optimize}\n" ":public method optimize {} {\n" "if {[set :multivalued]} return\n" "if {[set :defaultmethods] ne {get assign}} return\n" -"if {[:info callable -which assign] ne \"::xotcl::Slot alias assign ::xotcl::setinstvar\"} return\n" -"if {[:info callable -which get] ne \"::xotcl::Slot alias get ::xotcl::setinstvar\"} return\n" +"if {[:info callable -which assign] ne \"::xotcl::ObjectParameterSlot alias assign ::xotcl::setinstvar\"} return\n" +"if {[:info callable -which get] ne \"::xotcl::ObjectParameterSlot alias get ::xotcl::setinstvar\"} return\n" "::xotcl::setter ${:domain} {*}[expr {${:per-object} ? \"-per-object\" : \"\"}] ${:name}}}\n" -"::xotcl::Attribute mixin add ::xotcl::Slot::Optimizer\n" +"::xotcl::Attribute mixin add ::xotcl::ObjectParameterSlot::Optimizer\n" "::xotcl2::Class public method parameter arglist {\n" "if {![::xotcl::is [::xotcl::self]::slot object]} {\n" "::xotcl2::Object create [::xotcl::self]::slot}\n" "foreach arg $arglist {\n" -"set l [llength $arg]\n" -"set name [lindex $arg 0]\n" -"set opts [list]\n" -"set colonPos [string first : $name]\n" -"if {$colonPos > -1} {\n" -"set properties [string range $name [expr {$colonPos+1}] end]\n" -"set name [string range $name 0 [expr {$colonPos -1}]]\n" -"foreach property [split $properties ,] {\n" -"if {$property eq \"required\"} {\n" -"lappend opts -required 1} elseif {$property eq \"multivalued\"} {\n" -"lappend opts -multivalued 1} elseif {[string match type=* $property]} {\n" -"set type [string range $property 5 end]\n" -"if {![string match ::* $type]} {set type ::$type}} elseif {[string match arg=* $property]} {\n" -"set argument [string range $property 4 end]\n" -"lappend opts -arg $argument} else {\n" -"set type $property}}}\n" -"if {[info exists type]} {\n" -"lappend opts -type $type\n" -"unset type}\n" -"set cmd [list ::xotcl::Attribute create [::xotcl::self]::slot::$name {*}$opts]\n" -"if {$l == 1} {\n" -"eval $cmd} elseif {$l == 2} {\n" -"lappend cmd -default [lindex $arg 1]\n" -"eval $cmd} elseif {$l == 3 && [lindex $arg 1] eq \"-default\"} {\n" -"lappend cmd -default [lindex $arg 2]\n" -"eval $cmd} else {\n" -"set paramstring [string range $arg [expr {[string length $name]+1}] end]\n" -"if {[string match {[$\\[]*} $paramstring]} {\n" -"lappend cmd -default $paramstring\n" -"eval $cmd\n" -"continue}\n" -"set po ::xotcl2::Class::Parameter\n" -"puts stderr \"deprecated parameter usage '$arg'; use '-slots {Attribute ...}' instead\"\n" -"set cl [::xotcl::self]\n" -"::xotcl::setinstvar $po name $name\n" -"::xotcl::setinstvar $po cl [::xotcl::self]\n" -"::eval $po configure [lrange $arg 1 end]\n" -"if {[$po exists extra] || [$po exists setter] ||\n" -"[$po exists getter] || [$po exists access]} {\n" -"::xotcl::importvar $po extra setter getter access defaultParam\n" -"if {![info exists extra]} {set extra \"\"}\n" -"if {![info exists defaultParam]} {set defaultParam \"\"}\n" -"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 public 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" -".setter $name}}}\n" +"::xotcl::Attribute createFromParameterSyntax [self] {*}$arg}\n" "::xotcl::setinstvar [::xotcl::self]::slot __parameter $arglist}\n" "proc createBootstrapAttributeSlots {} {}}\n" "::xotcl2::Class create ::xotcl::ScopedNew -superclass ::xotcl2::Class -parameter {\n" "{withclass ::xotcl2::Object}\n" "inobject}\n" -"::xotcl::ScopedNew method init {} {\n" +"::xotcl::ScopedNew protected method init {} {\n" ":public method new {-childof args} {\n" "::xotcl::importvar [::xotcl::self class] {inobject object} withclass\n" "if {![::xotcl::is $object object]} {\n" Index: generic/predefined.xotcl =================================================================== diff -u -r05f4b42f7615ea410b7ac33093f5b8382ce7e8c5 -r48d5751e9aeb6a4f388f6531a9248c1847b22cae --- generic/predefined.xotcl (.../predefined.xotcl) (revision 05f4b42f7615ea410b7ac33093f5b8382ce7e8c5) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision 48d5751e9aeb6a4f388f6531a9248c1847b22cae) @@ -304,69 +304,69 @@ # if {![::xotcl::is $slotobject object]} {::xotcls::Object create $slotobject} # eval next -childof $slotobject $args # } - + ::xotcl::MetaSlot create ::xotcl::Slot + ::xotcl::MetaSlot create ::xotcl::ObjectParameterSlot + ::xotcl::relation ::xotcl::ObjectParameterSlot superclass ::xotcl::Slot + # We have no working objectparameter yet. So invalidate MetaSlot to # avoid caching. ::xotcl::MetaSlot __invalidateobjectparameter - #foreach o {::xotcl::MetaSlot ::xotcl2::Slot} { + #foreach o {::xotcl::MetaSlot ::xotcl2::ObjectParameterSlot} { # foreach r {object class metaclass} { # puts stderr "$o $r=[::xotcl::is $o $r]" # } #} - + # Provide the a slot based mechanism for building an object # configuration interface from slot definitions - proc ::xotcl::parameterFromSlot {slot name} { + ::xotcl::ObjectParameterSlot method toParameterSyntax {name} { set objparamdefinition $name set methodparamdefinition "" set objopts [list] set methodopts [list] - if {[$slot exists required] && [$slot required]} { + if {[info exists :required] && ${:required}} { lappend objopts required lappend methodopts required } - if {[$slot exists type]} { - set type [$slot type] - if {[string match ::* $type]} { - lappend objopts object type=$type - lappend methodopts object type=$type + if {[info exists :type]} { + if {[string match ::* ${:type}]} { + lappend objopts object type=${:type} + lappend methodopts object type=${:type} } else { - lappend objopts $type - lappend methodopts $type + lappend objopts ${:type} + lappend methodopts ${:type} } } # TODO: remove multivalued check on relations by handling multivalued # not in relation, but in the converters - if {[$slot exists multivalued] && [$slot multivalued]} { - if {!([$slot exists type] && [$slot type] eq "relation")} { + if {[info exists :multivalued] && ${:multivalued}} { + if {!([info exists :type] && ${:type} eq "relation")} { lappend objopts multivalued } else { #puts stderr "ignore multivalued for $name in relation" } } - if {[$slot exists arg]} { - lappend objopts arg=[$slot arg] - lappend methodopts arg=[$slot arg] + if {[info exists :arg]} { + lappend objopts arg=${:arg} + lappend methodopts arg=${:arg} } - if {[$slot exists default]} { - set arg [::xotcl::setinstvar $slot default] + if {[info exists :default]} { + set arg ${:default} # deactivated for now: || [string first {$} $arg] > -1 if {[string match {*\[*\]*} $arg]} { lappend objopts substdefault } - } elseif {[$slot exists initcmd]} { - set arg [::xotcl::setinstvar $slot initcmd] + } elseif {[info exists :initcmd]} { + set arg ${:initcmd} lappend objopts initcmd - } - if {[$slot exists methodname]} { - set methodname [$slot methodname] - set slotname [$slot name] - if {$methodname ne $slotname} { - lappend objopts arg=$methodname - lappend methodopts arg=$methodname - #puts stderr "..... setting arg for methodname: $slot has arg arg=$methodname" + } + if {[info exists :methodname]} { + if {${:methodname} ne ${:name}} { + lappend objopts arg=${:methodname} + lappend methodopts arg=${:methodname} + #puts stderr "..... setting arg for methodname: $slot has arg arg=${:methodname}" } } if {[llength $objopts] > 0} { @@ -378,20 +378,20 @@ if {[info exists arg]} { lappend objparamdefinition $arg } - #puts stderr "parameterFromSlot {$slot $name} returns [list oparam $objparamdefinition mparam $methodparamdefinition]" + #puts stderr "[self proc] ${name} returns [list oparam $objparamdefinition mparam $methodparamdefinition]" return [list oparam $objparamdefinition mparam $methodparamdefinition] } - + proc ::xotcl::parametersFromSlots {obj} { set parameterdefinitions [list] - set slots [::xotcl2::objectInfo slotobjects $obj] - foreach slot $slots { - # skip some lots for xotcl1; TODO: maybe different parameterFromSlots for xotcl1? + foreach slot [::xotcl2::objectInfo slotobjects $obj] { + # Skip some slots for xotcl1; + # TODO: maybe different parameterFromSlots for xotcl1? if {[::xotcl::is $obj type ::xotcl::Object] && ([$slot name] eq "mixin" || [$slot name] eq "filter") } continue set name [namespace tail $slot] - array set "" [::xotcl::parameterFromSlot $slot $name] + array set "" [$slot toParameterSyntax $name] lappend parameterdefinitions -$(oparam) } return $parameterdefinitions @@ -415,14 +415,15 @@ # # create class and object for method parameter slots ::xotcl::MetaSlot create ::xotcl::MethodParameterSlot + ::xotcl::relation ::xotcl::MethodParameterSlot superclass ::xotcl::Slot + foreach cmd [info command ::xotcl::cmd::MethodParameterSlot::*] { ::xotcl::alias ::xotcl::MethodParameterSlot [namespace tail $cmd] $cmd } # create an object for dispatching ::xotcl::MethodParameterSlot create ::xotcl::methodParameterSlot - # use low level interface for defining slot values. Normally, this is # done via slot objects, which are defined later. @@ -432,7 +433,7 @@ } foreach att $definitions { if {[llength $att]>1} {foreach {att default} $att break} - ::xotcl::Slot create ${class}::slot::$att + ::xotcl::ObjectParameterSlot create ${class}::slot::$att if {[info exists default]} { ::xotcl::setinstvar ${class}::slot::$att default $default unset default @@ -468,27 +469,30 @@ # Define slots for slots ############################################ createBootstrapAttributeSlots ::xotcl::Slot { + {name} + {multivalued false} + {required false} + default + type + } + + createBootstrapAttributeSlots ::xotcl::ObjectParameterSlot { {name "[namespace tail [::xotcl::self]]"} {methodname} {domain "[lindex [regexp -inline {^(.*)::slot::[^:]+$} [::xotcl::self]] 1]"} {defaultmethods {get assign}} {manager "[::xotcl::self]"} - {multivalued false} {per-object false} - {forward-per-object} - {required false} - default - type } # maybe add the following slots at some later time here # initcmd # valuecmd # valuechangedcmd - ::xotcl::alias ::xotcl::Slot get ::xotcl::setinstvar - ::xotcl::alias ::xotcl::Slot assign ::xotcl::setinstvar + ::xotcl::alias ::xotcl::ObjectParameterSlot get ::xotcl::setinstvar + ::xotcl::alias ::xotcl::ObjectParameterSlot assign ::xotcl::setinstvar - ::xotcl::Slot public method add {obj prop value {pos 0}} { + ::xotcl::ObjectParameterSlot public method add {obj prop value {pos 0}} { if {![set :multivalued]} { error "Property $prop of [set :domain]->$obj ist not multivalued" } @@ -498,15 +502,15 @@ ::xotcl::setinstvar $obj $prop [list $value] } } - ::xotcl::Slot public method delete {-nocomplain:switch obj prop value} { + ::xotcl::ObjectParameterSlot public method delete {-nocomplain:switch obj prop value} { set old [::xotcl::setinstvar $obj $prop] set p [lsearch -glob $old $value] if {$p>-1} {::xotcl::setinstvar $obj $prop [lreplace $old $p $p]} else { error "$value is not a $prop of $obj (valid are: $old)" } } - ::xotcl::Slot method unknown {method args} { + ::xotcl::ObjectParameterSlot method unknown {method args} { set methods [list] foreach m [:info callable] { if {[::xotcl2::Object info callable $m] ne ""} continue @@ -516,14 +520,14 @@ error "Method '$method' unknown for slot [::xotcl::self]; valid are: {[lsort $methods]]}" } - ::xotcl::Slot public method destroy {} { + ::xotcl::ObjectParameterSlot public method destroy {} { if {${:domain} ne "" && [::xotcl::is ${:domain} object]} { ${:domain} __invalidateobjectparameter } next } - ::xotcl::Slot method init {args} { + ::xotcl::ObjectParameterSlot protected method init {args} { if {${:domain} eq ""} { set :domain [::xotcl::self callingobject] } @@ -550,7 +554,7 @@ {type relation} {elementtype ::xotcl2::Class} } - ::xotcl::relation ::xotcl::RelationSlot superclass ::xotcl::Slot + ::xotcl::relation ::xotcl::RelationSlot superclass ::xotcl::ObjectParameterSlot ::xotcl::alias ::xotcl::RelationSlot assign ::xotcl::relation ::xotcl::RelationSlot protected method init {} { @@ -619,30 +623,26 @@ ::xotcl::RelationSlot create ${os}::Object::slot::class -multivalued false ::xotcl::alias ${os}::Object::slot::class assign ::xotcl::relation - ::xotcl::RelationSlot create ${os}::Object::slot::mixin \ - -methodname object-mixin + ::xotcl::RelationSlot create ${os}::Object::slot::mixin -methodname object-mixin + ::xotcl::RelationSlot create ${os}::Object::slot::filter -elementtype "" - ::xotcl::RelationSlot create ${os}::Object::slot::filter \ - -elementtype "" - - ::xotcl::RelationSlot create ${os}::Class::slot::mixin \ - -methodname class-mixin - ::xotcl::RelationSlot create ${os}::Class::slot::filter \ + ::xotcl::RelationSlot create ${os}::Class::slot::mixin -methodname class-mixin + ::xotcl::RelationSlot create ${os}::Class::slot::filter -elementtype "" \ -methodname filter-mixin - # create tho conveniance slots to allow configuration of + # Create two conveniance slots to allow configuration of # object-slots for classes via object-mixin ::xotcl::RelationSlot create ${os}::Class::slot::object-mixin - ::xotcl::RelationSlot create ${os}::Class::slot::object-filter \ - -elementtype "" + ::xotcl::RelationSlot create ${os}::Class::slot::object-filter -elementtype "" } ::xotcl::register_system_slots ::xotcl2 + proc ::xotcl::register_system_slots {} {} ############################################ # Attribute slots ############################################ ::xotcl::MetaSlot __invalidateobjectparameter - ::xotcl::MetaSlot create ::xotcl::Attribute -superclass ::xotcl::Slot + ::xotcl::MetaSlot create ::xotcl::Attribute -superclass ::xotcl::ObjectParameterSlot createBootstrapAttributeSlots ::xotcl::Attribute { {value_check once} @@ -651,7 +651,42 @@ valuechangedcmd arg } - + + ::xotcl::Attribute object method createFromParameterSyntax {target value default:optional} { + set opts [list] + set colonPos [string first : $value] + if {$colonPos == -1} { + set name $value + } else { + set properties [string range $value [expr {$colonPos+1}] end] + set name [string range $value 0 [expr {$colonPos -1}]] + foreach property [split $properties ,] { + if {$property eq "required"} { + lappend opts -required 1 + } elseif {$property eq "multivalued"} { + lappend opts -multivalued 1 + } elseif {[string match type=* $property]} { + set type [string range $property 5 end] + if {![string match ::* $type]} {set type ::$type} + } elseif {[string match arg=* $property]} { + set argument [string range $property 4 end] + lappend opts -arg $argument + } else { + set type $property + } + } + } + if {[info exists type]} { + lappend opts -type $type + } + + if {[info exists default]} { + lappend opts -default $default + } + + ::xotcl::Attribute create ${target}::slot::$name {*}$opts + } + ::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] @@ -712,7 +747,7 @@ } return $__initcmd } - ::xotcl::Attribute method init {} { + ::xotcl::Attribute protected method init {} { next ;# do first ordinary slot initialization # there might be already default values registered on the class set __initcmd "" @@ -724,7 +759,8 @@ append __initcmd ":trace add variable [list ${:name}] read \ \[list [::xotcl::self] __value_from_cmd \[::xotcl::self\] [list [set :valuecmd]]\]" } - array set "" [::xotcl::parameterFromSlot [self] "value"] + array set "" [:toParameterSyntax "value"] + #puts stderr "Attribute.init valueParam for [self] is $(mparam)" if {$(mparam) ne ""} { if {[info exists :multivalued] && ${:multivalued}} { @@ -748,119 +784,46 @@ } # mixin class for decativating all value checks in slots - ::xotcl2::Class create ::xotcl::Slot::Nocheck { + ::xotcl2::Class create ::xotcl::ObjectParameterSlot::Nocheck { :method check_single_value args {;} :method check_multiple_values args {;} :method mk_type_checker args {return ""} } # mixin class for optimizing slots - ::xotcl2::Class create ::xotcl::Slot::Optimizer { + ::xotcl2::Class create ::xotcl::ObjectParameterSlot::Optimizer { :method method args {::xotcl::next; :optimize} :method forward args {::xotcl::next; :optimize} - :method init args {::xotcl::next; :optimize} + :protected method init args {::xotcl::next; :optimize} :public method optimize {} { #puts stderr OPTIMIZER if {[set :multivalued]} return if {[set :defaultmethods] ne {get assign}} return #puts stderr assign=[:info callable -which assign] - if {[:info callable -which assign] ne "::xotcl::Slot alias assign ::xotcl::setinstvar"} return - if {[:info callable -which get] ne "::xotcl::Slot alias get ::xotcl::setinstvar"} return + if {[:info callable -which assign] ne "::xotcl::ObjectParameterSlot alias assign ::xotcl::setinstvar"} return + if {[:info callable -which get] ne "::xotcl::ObjectParameterSlot alias get ::xotcl::setinstvar"} return #puts stderr "**** optimizing [${:domain} info method definition ${:name}]" ::xotcl::setter ${:domain} {*}[expr {${:per-object} ? "-per-object" : ""}] ${:name} } } # register the optimizer per default - ::xotcl::Attribute mixin add ::xotcl::Slot::Optimizer + ::xotcl::Attribute mixin add ::xotcl::ObjectParameterSlot::Optimizer ############################################ # Define method "parameter" for backward # compatibility and convenience ############################################ ::xotcl2::Class public method parameter arglist { + + # create subobject "slot" if necessary if {![::xotcl::is [::xotcl::self]::slot object]} { ::xotcl2::Object create [::xotcl::self]::slot } foreach arg $arglist { - set l [llength $arg] - set name [lindex $arg 0] - set opts [list] - set colonPos [string first : $name] - if {$colonPos > -1} { - set properties [string range $name [expr {$colonPos+1}] end] - set name [string range $name 0 [expr {$colonPos -1}]] - foreach property [split $properties ,] { - if {$property eq "required"} { - lappend opts -required 1 - } elseif {$property eq "multivalued"} { - lappend opts -multivalued 1 - } elseif {[string match type=* $property]} { - set type [string range $property 5 end] - if {![string match ::* $type]} {set type ::$type} - } elseif {[string match arg=* $property]} { - set argument [string range $property 4 end] - lappend opts -arg $argument - } else { - set type $property - } - } - } - if {[info exists type]} { - lappend opts -type $type - unset type - } - - set cmd [list ::xotcl::Attribute create [::xotcl::self]::slot::$name {*}$opts] - #puts stderr cmd=$cmd - - if {$l == 1} { - eval $cmd - #puts stderr "parameter $arg without default -> $cmd" - } elseif {$l == 2} { - lappend cmd -default [lindex $arg 1] - eval $cmd - } elseif {$l == 3 && [lindex $arg 1] eq "-default"} { - lappend cmd -default [lindex $arg 2] - eval $cmd - } else { - set paramstring [string range $arg [expr {[string length $name]+1}] end] - if {[string match {[$\[]*} $paramstring]} { - lappend cmd -default $paramstring - eval $cmd - continue - } - - set po ::xotcl2::Class::Parameter - puts stderr "deprecated parameter usage '$arg'; use '-slots {Attribute ...}' instead" - - set cl [::xotcl::self] - ::xotcl::setinstvar $po name $name - ::xotcl::setinstvar $po cl [::xotcl::self] - ::eval $po configure [lrange $arg 1 end] - - if {[$po exists extra] || [$po exists setter] || - [$po exists getter] || [$po exists access]} { - ::xotcl::importvar $po extra setter getter access defaultParam - if {![info exists extra]} {set extra ""} - if {![info exists defaultParam]} {set defaultParam ""} - if {![info exists setter]} {set setter set} - if {![info exists getter]} {set getter set} - if {![info exists access]} {set access ::xotcl::my} - $cl public method $name args " - if {\[llength \$args] == 0} { - return \[$access $getter $extra $name\] - } else { - return \[eval $access $setter $extra $name \$args $defaultParam \] - }" - foreach instvar {extra defaultParam setter getter access} { - $po unset -nocomplain $instvar - } - } else { - .setter $name - } - } + ::xotcl::Attribute createFromParameterSyntax [self] {*}$arg } + # todo needed? ::xotcl::setinstvar [::xotcl::self]::slot __parameter $arglist } @@ -879,7 +842,7 @@ {withclass ::xotcl2::Object} inobject } -::xotcl::ScopedNew method init {} { +::xotcl::ScopedNew protected method init {} { :public method new {-childof args} { ::xotcl::importvar [::xotcl::self class] {inobject object} withclass if {![::xotcl::is $object object]} { @@ -1128,6 +1091,5 @@ } } } - unset bootstrap } Index: generic/xotcl.c =================================================================== diff -u -r05f4b42f7615ea410b7ac33093f5b8382ce7e8c5 -r48d5751e9aeb6a4f388f6531a9248c1847b22cae --- generic/xotcl.c (.../xotcl.c) (revision 05f4b42f7615ea410b7ac33093f5b8382ce7e8c5) +++ generic/xotcl.c (.../xotcl.c) (revision 48d5751e9aeb6a4f388f6531a9248c1847b22cae) @@ -1697,7 +1697,8 @@ * initialize the variable hash table and update the object */ varTablePtr = object->varTable = VarHashTableCreate(); - fprintf(stderr, "+++ create varTable in CompiledDotVarFetch\n"); + fprintf(stderr, "+++ create varTable in %s CompiledDotVarFetch for '%s'\n", + objectName(object), ObjStr(resVarInfo->nameObj)); } resVarInfo->lastObj = object; @@ -5253,7 +5254,7 @@ static void ParamsFree(XOTclParam *paramsPtr) { XOTclParam *paramPtr; - + /*fprintf(stderr, "ParamsFree %p\n", paramsPtr);*/ for (paramPtr=paramsPtr; paramPtr->name; paramPtr++) { /*fprintf(stderr, ".... paramPtr = %p, name=%s, defaultValue %p\n", paramPtr, paramPtr->name, paramPtr->defaultValue);*/ @@ -9521,10 +9522,10 @@ int i; for (pPtr = ifd, i=0; i %p %p, default %s\n", - pPtr->name, pPtr->flags & XOTCL_ARG_REQUIRED, - pcPtr->clientData[i], pcPtr->objv[i], - pPtr->defaultValue ? ObjStr(pPtr->defaultValue) : "NONE");*/ + /*fprintf(stderr, "ArgumentDefaults got for arg %s (%d) %p => %p %p, default %s\n", + pPtr->name, pPtr->flags & XOTCL_ARG_REQUIRED, pPtr, + pcPtr->clientData[i], pcPtr->objv[i], + pPtr->defaultValue ? ObjStr(pPtr->defaultValue) : "NONE");*/ if (pcPtr->objv[i]) { /* we got an actual value, which was already checked by objv parser */ @@ -12274,6 +12275,7 @@ 2, 0, XOTCL_CM_NO_PROTECT); if (result == TCL_OK) { rawConfArgs = Tcl_GetObjResult(interp); + /*fprintf(stderr, ".... rawConfArgs for %s => %s\n", objectName(object), ObjStr(rawConfArgs));*/ INCR_REF_COUNT(rawConfArgs); /* Parse the string representation to obtain the internal representation */ Index: library/lib/xotcl1.xotcl =================================================================== diff -u -r05f4b42f7615ea410b7ac33093f5b8382ce7e8c5 -r48d5751e9aeb6a4f388f6531a9248c1847b22cae --- library/lib/xotcl1.xotcl (.../xotcl1.xotcl) (revision 05f4b42f7615ea410b7ac33093f5b8382ce7e8c5) +++ library/lib/xotcl1.xotcl (.../xotcl1.xotcl) (revision 48d5751e9aeb6a4f388f6531a9248c1847b22cae) @@ -121,10 +121,12 @@ #xotcl::setinstvar ::xotcl::Class __default_metaclass ::xotcl::Class -############################################ -# system slots -############################################ - proc register_system_slots1 {os} { + ############################################ + # system slots + ############################################ + proc register_system_slots {os} { + # We need explicit ::xotcl prefixes, since they are always skipped + # if not specified ${os}::Object alloc ${os}::Class::slot ${os}::Object alloc ${os}::Object::slot @@ -138,15 +140,16 @@ ::xotcl::RelationSlot create ${os}::Object::slot::filter \ -methodname object-filter \ -elementtype "" + ::xotcl::RelationSlot create ${os}::Class::slot::instmixin \ -methodname class-mixin ::xotcl::RelationSlot create ${os}::Class::slot::instfilter \ -methodname class-filter \ -elementtype "" } - ::xotcl::register_system_slots1 ::xotcl + register_system_slots ::xotcl + proc ::xotcl::register_system_slots {} {} - ######################## # Info definition ######################## Index: tests/aliastest.xotcl =================================================================== diff -u -r210eab6d9149846d5d6a6a8e0fa74e232ca5b6de -r48d5751e9aeb6a4f388f6531a9248c1847b22cae --- tests/aliastest.xotcl (.../aliastest.xotcl) (revision 210eab6d9149846d5d6a6a8e0fa74e232ca5b6de) +++ tests/aliastest.xotcl (.../aliastest.xotcl) (revision 48d5751e9aeb6a4f388f6531a9248c1847b22cae) @@ -4,8 +4,8 @@ Test parameter count 10 # The system methods of Object are either alias or forwarders -? {lsort [::xotcl::Slot info methods -methodtype alias]} {assign get} -? {::xotcl::Slot info method definition get} "::xotcl::Slot alias get ::xotcl::setinstvar" +? {lsort [::xotcl::ObjectParameterSlot info methods -methodtype alias]} {assign get} +? {::xotcl::ObjectParameterSlot info method definition get} "::xotcl::ObjectParameterSlot alias get ::xotcl::setinstvar" # define an alias and retrieve its definition set cmd "::xotcl2::Object alias -objscope set ::set" Index: tests/parameters.xotcl =================================================================== diff -u -r05f4b42f7615ea410b7ac33093f5b8382ce7e8c5 -r48d5751e9aeb6a4f388f6531a9248c1847b22cae --- tests/parameters.xotcl (.../parameters.xotcl) (revision 05f4b42f7615ea410b7ac33093f5b8382ce7e8c5) +++ tests/parameters.xotcl (.../parameters.xotcl) (revision 48d5751e9aeb6a4f388f6531a9248c1847b22cae) @@ -72,7 +72,6 @@ # {manager "[::xotcl::self]"} # {multivalued false} # {per-object false} -# {forward-per-object} # {required false} # default # type @@ -596,7 +595,7 @@ # TODO: we have no good interface for querying the slot notation for parameters proc parameterFromSlot {class objectparameter} { set slot ${class}::slot::$objectparameter - array set "" [::xotcl::parameterFromSlot $slot $objectparameter] + array set "" [$slot toParameterSyntax $objectparameter] return $(oparam) } Index: tests/slottest.xotcl =================================================================== diff -u -r05f4b42f7615ea410b7ac33093f5b8382ce7e8c5 -r48d5751e9aeb6a4f388f6531a9248c1847b22cae --- tests/slottest.xotcl (.../slottest.xotcl) (revision 05f4b42f7615ea410b7ac33093f5b8382ce7e8c5) +++ tests/slottest.xotcl (.../slottest.xotcl) (revision 48d5751e9aeb6a4f388f6531a9248c1847b22cae) @@ -111,7 +111,7 @@ #? {O2 superclass O} "superclass 1" ? {O superclass} "::xotcl::Object" -::xotcl::Slot method slot {object name property} { +::xotcl::ObjectParameterSlot method slot {object name property} { switch $property { self {return [self]} domain {return [my domain]} @@ -130,7 +130,7 @@ # the main difference between an Attribute and a Role is that # it references some other objects -#Class Attribute -superclass ::xotcl::Slot +#Class Attribute -superclass ::xotcl::ObjectParameterSlot Class Role -superclass Attribute -parameter {references} ###################### @@ -251,7 +251,7 @@ # } # } -::xotcl::Attribute mixin delete ::xotcl::Slot::Optimizer +::xotcl::Attribute mixin delete ::xotcl::ObjectParameterSlot::Optimizer Class C1 -parameter {a {b 10} {c "Hello World"}} C1 c1 -a 1 @@ -277,7 +277,7 @@ ? {c2 a} 1 "new indirect parametercmd" ? {c2 a 1} 1 "new indirect parametercmd" -::xotcl::Slot mixin add ::xotcl::Slot::Optimizer +::xotcl::ObjectParameterSlot mixin add ::xotcl::ObjectParameterSlot::Optimizer Class C3 -slots { Attribute create a @@ -319,7 +319,7 @@ ? {a0 procsearch f3} "::a0 proc f3" ? {a0 procsearch f4} "::a0 forward f4" ? {a0 procsearch set} "::xotcl::Object instcmd set" -? {A slot foo info callable -which assign} "::xotcl::Slot alias assign ::xotcl::setinstvar" +? {A slot foo info callable -which assign} "::xotcl::ObjectParameterSlot alias assign ::xotcl::setinstvar" # redefine setter for foo of class A A slot foo method assign {domain var val} { @@ -362,7 +362,7 @@ #p1 projects add some-other-value #? {p1 projects} "some-other-value ::project1" -::xotcl::Slot method check { +::xotcl::ObjectParameterSlot method check { {-keep_old_value:boolean true} value predicate type obj var } { @@ -378,7 +378,7 @@ if {$keep_old_value} {$obj set __oldvalue($var) $value} } -::xotcl::Slot method checkall {values predicate type obj var} { +::xotcl::ObjectParameterSlot method checkall {values predicate type obj var} { foreach value $values { my check -keep_old_value false $value $predicate $type $obj $var } Index: tests/testx.xotcl =================================================================== diff -u -rfe19549734064c3a57866e7e47743ec787f647e5 -r48d5751e9aeb6a4f388f6531a9248c1847b22cae --- tests/testx.xotcl (.../testx.xotcl) (revision fe19549734064c3a57866e7e47743ec787f647e5) +++ tests/testx.xotcl (.../testx.xotcl) (revision 48d5751e9aeb6a4f388f6531a9248c1847b22cae) @@ -1559,10 +1559,10 @@ for {set i 0} {$i < $n} {incr i} { Class O -parameter { - {a -default 0} - {b -default {[cmd 3 4]}} c d - {e -default 3} - {Self -default [self]} + {a 0} + {b {[cmd 3 4]}} c d + {e 3} + {Self [self]} } O instproc init args { global initResult @@ -1578,8 +1578,8 @@ } Class Meta -superclass Class Meta instproc create args {next; return Meta-create} - Meta C -superclass O -parameter {a {b -default ""} {c -default 1}} - Class D -parameter {a {c -default 1}} -superclass O + Meta C -superclass O -parameter {a {b ""} {c 1}} + Class D -parameter {a {c 1}} -superclass O # create on class should not be called D instproc create args {next; return D-create} D instproc init args {