Index: generic/predefined.h =================================================================== diff -u -r4ce2a0659cf44b3dbb7262f63fadb3333c968751 -r5524b83ed5dda30e55f7a02e4c22d26783688954 --- generic/predefined.h (.../predefined.h) (revision 4ce2a0659cf44b3dbb7262f63fadb3333c968751) +++ generic/predefined.h (.../predefined.h) (revision 5524b83ed5dda30e55f7a02e4c22d26783688954) @@ -151,41 +151,50 @@ "::xotcl::MetaSlot create ::xotcl::Slot\n" "::xotcl::MetaSlot __invalidateobjectparameter\n" "proc ::xotcl::parameterFromSlot {slot name} {\n" -"set parameterdefinition $name\n" -"set opts [list]\n" +"set objparamdefinition $name\n" +"set methodparamdefinition \"\"\n" +"set objopts [list]\n" +"set methodopts [list]\n" "if {[$slot exists required] && [$slot required]} {\n" -"lappend opts required}\n" +"lappend objopts required\n" +"lappend methodopts required}\n" "if {[$slot exists type]} {\n" -"lappend opts [$slot type]}\n" +"lappend objopts [$slot type]\n" +"lappend methodopts [$slot type]}\n" "if {[$slot exists multivalued] && [$slot multivalued]} {\n" "if {!([$slot exists type] && [$slot type] eq \"relation\")} {\n" -"lappend opts multivalued} else {}}\n" +"lappend objopts multivalued} else {}}\n" "if {[$slot exists arg]} {\n" -"lappend opts arg=[$slot 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 {[string match {*\\[*\\]*} $arg]} {\n" -"lappend opts substdefault}} elseif {[$slot exists initcmd]} {\n" +"lappend objopts substdefault}} elseif {[$slot exists initcmd]} {\n" "set arg [::xotcl::setinstvar $slot initcmd]\n" -"lappend opts 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 opts arg=$methodname}}\n" -"if {[llength $opts] > 0} {\n" -"append parameterdefinition :[join $opts ,]}\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" +"set methodparamdefinition [join $methodopts ,]}\n" "if {[info exists arg]} {\n" -"lappend parameterdefinition $arg}\n" -"return $parameterdefinition}\n" +"lappend objparamdefinition $arg}\n" +"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" "if {[::xotcl::is $obj type ::xotcl::Object] &&\n" "([$slot name] eq \"mixin\" || [$slot name] eq \"filter\")} continue\n" "set name [namespace tail $slot]\n" -"lappend parameterdefinitions -[::xotcl::parameterFromSlot $slot $name]}\n" +"array set \"\" [::xotcl::parameterFromSlot $slot $name]\n" +"lappend parameterdefinitions -$(oparam)}\n" "return $parameterdefinitions}\n" "::xotcl2::Object protected method objectparameter {} {\n" "set parameterdefinitions [::xotcl::parametersFromSlots [self]]\n" @@ -378,13 +387,12 @@ "\\[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" -"set valueParam [lindex [::xotcl::parameterFromSlot [self] \"value\"] 0]\n" -"if {$valueParam ne \"value\" && [string first : $valueParam] > -1} {\n" -":method assign [list obj var $valueParam] {::xotcl::setinstvar $obj $var $value}\n" -"if {[set :multivalued]} {\n" -"regsub ,multivalued $valueParam \"\" param\n" -"puts stderr \"adding add method for [self] with $param\"\n" -":method add [list obj prop $param {pos 0}] {next}}}\n" +"array set \"\" [::xotcl::parameterFromSlot [self] \"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" +":method add [list obj prop value:$(mparam) {pos 0}] {next}} else {\n" +":method assign [list obj var value:$(mparam)] {::xotcl::setinstvar $obj $var $value}}}\n" "if {[:exists valuechangedcmd]} {\n" "append __initcmd \":trace add variable [list ${:name}] write \\\n" "\\[list [::xotcl::self] __value_changed_cmd \\[::xotcl::self\\] [list [set :valuechangedcmd]]\\]\"}\n" Index: generic/predefined.xotcl =================================================================== diff -u -r4ce2a0659cf44b3dbb7262f63fadb3333c968751 -r5524b83ed5dda30e55f7a02e4c22d26783688954 --- generic/predefined.xotcl (.../predefined.xotcl) (revision 4ce2a0659cf44b3dbb7262f63fadb3333c968751) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision 5524b83ed5dda30e55f7a02e4c22d26783688954) @@ -318,52 +318,61 @@ # Provide the a slot based mechanism for building an object # configuration interface from slot definitions proc ::xotcl::parameterFromSlot {slot name} { - set parameterdefinition $name - set opts [list] + set objparamdefinition $name + set methodparamdefinition "" + set objopts [list] + set methodopts [list] if {[$slot exists required] && [$slot required]} { - lappend opts required + lappend objopts required + lappend methodopts required } if {[$slot exists type]} { - lappend opts [$slot type] + lappend objopts [$slot type] + lappend methodopts [$slot 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")} { - lappend opts multivalued + lappend objopts multivalued } else { #puts stderr "ignore multivalued for $name in relation" } } if {[$slot exists arg]} { - lappend opts arg=[$slot arg] + lappend objopts arg=[$slot arg] + lappend methodopts arg=[$slot arg] } if {[$slot exists default]} { set arg [::xotcl::setinstvar $slot default] # deactivated for now: || [string first {$} $arg] > -1 if {[string match {*\[*\]*} $arg]} { - lappend opts substdefault + lappend objopts substdefault } } elseif {[$slot exists initcmd]} { set arg [::xotcl::setinstvar $slot initcmd] - lappend opts initcmd + lappend objopts initcmd } if {[$slot exists methodname]} { set methodname [$slot methodname] set slotname [$slot name] if {$methodname ne $slotname} { - lappend opts arg=$methodname + lappend objopts arg=$methodname + lappend methodopts arg=$methodname #puts stderr "..... setting arg for methodname: $slot has arg arg=$methodname" } } - if {[llength $opts] > 0} { - append parameterdefinition :[join $opts ,] + if {[llength $objopts] > 0} { + append objparamdefinition :[join $objopts ,] } + if {[llength $methodopts] > 0} { + set methodparamdefinition [join $methodopts ,] + } if {[info exists arg]} { - lappend parameterdefinition $arg + lappend objparamdefinition $arg } - #puts stderr "parameterFromSlot {$slot $name} returns $parameterdefinition" - return $parameterdefinition + #puts stderr "parameterFromSlot {$slot $name} returns [list oparam $objparamdefinition mparam $methodparamdefinition]" + return [list oparam $objparamdefinition mparam $methodparamdefinition] } proc ::xotcl::parametersFromSlots {obj} { @@ -375,7 +384,8 @@ ([$slot name] eq "mixin" || [$slot name] eq "filter") } continue set name [namespace tail $slot] - lappend parameterdefinitions -[::xotcl::parameterFromSlot $slot $name] + array set "" [::xotcl::parameterFromSlot $slot $name] + lappend parameterdefinitions -$(oparam) } return $parameterdefinitions } @@ -722,16 +732,17 @@ append __initcmd ":trace add variable [list ${:name}] read \ \[list [::xotcl::self] __value_from_cmd \[::xotcl::self\] [list [set :valuecmd]]\]" } - set valueParam [lindex [::xotcl::parameterFromSlot [self] "value"] 0] - #puts stderr "valueParam for [self] is $valueParam" - if {$valueParam ne "value" && [string first : $valueParam] > -1} { - #puts stderr "adding assign [list obj var $valueParam] // for [self] with $valueParam" - :method assign [list obj var $valueParam] {::xotcl::setinstvar $obj $var $value} - if {[set :multivalued]} { - # remove multivalued flag and use "next" to handle actual adding - regsub ,multivalued $valueParam "" param - puts stderr "adding add method for [self] with $param" - :method add [list obj prop $param {pos 0}] {next} + array set "" [::xotcl::parameterFromSlot [self] "value"] + #puts stderr "Attribute.init valueParam for [self] is $(mparam)" + if {$(mparam) ne ""} { + if {[info exists :multivalued] && ${:multivalued}} { + #puts stderr "adding assign [list obj var value:$(mparam),multivalued] // for [self] with $(mparam)" + :method assign [list obj var value:$(mparam),multivalued] {::xotcl::setinstvar $obj $var $value} + #puts stderr "adding add method for [self] with value:$(mparam)" + :method add [list obj prop value:$(mparam) {pos 0}] {next} + } else { + #puts stderr "adding assign [list obj var value:$(mparam)] // for [self] with $(mparam)" + :method assign [list obj var value:$(mparam)] {::xotcl::setinstvar $obj $var $value} } } #append __initcmd [:mk_type_checker] Index: generic/xotcl.c =================================================================== diff -u -r4a478eb598eea7cc8dec70222777d114c55f1ff8 -r5524b83ed5dda30e55f7a02e4c22d26783688954 --- generic/xotcl.c (.../xotcl.c) (revision 4a478eb598eea7cc8dec70222777d114c55f1ff8) +++ generic/xotcl.c (.../xotcl.c) (revision 5524b83ed5dda30e55f7a02e4c22d26783688954) @@ -5580,7 +5580,7 @@ result = PushProcCallFrame(cp, interp, objc, objv, cscPtr); # endif - /* we could consider to run here ARGS_METHO or INITCMD + /* we could consider to run here ARG_METHOD or ARG_INITCMD if (result == TCL_OK) { } */ @@ -6304,7 +6304,7 @@ ParamOptionParse(Tcl_Interp *interp, char *option, int length, int disallowedOptions, XOTclParam *paramPtr) { int result = TCL_OK; - /*fprintf(stderr, "def %s, option '%s' (%d)\n", paramPtr->name, option, length);*/ + /*fprintf(stderr, "ParamOptionParse name %s, option '%s' (%d) disallowed %.6x\n", paramPtr->name, option, length, disallowedOptions);*/ if (strncmp(option, "required", MAX(3,length)) == 0) { paramPtr->flags |= XOTCL_ARG_REQUIRED; } else if (strncmp(option, "optional", MAX(3,length)) == 0) { @@ -6325,6 +6325,7 @@ INCR_REF_COUNT(paramPtr->converterArg); } else if (strncmp(option, "switch", 6) == 0) { result = ParamOptionSetConverter(interp, paramPtr, "switch", convertToSwitch); + paramPtr->flags |= XOTCL_ARG_SWITCH; paramPtr->nrArgs = 0; assert(paramPtr->defaultValue == NULL); paramPtr->defaultValue = Tcl_NewBooleanObj(0); @@ -6569,7 +6570,7 @@ result = CanRedefineCmd(interp, nsPtr, object, methodName); if (result == TCL_OK) { /* Yes, so obtain an method parameter definitions */ - result = ParamDefsParse(interp, methodName, args, XOTCL_ARG_METHOD_PARAMETER, &parsedParam); + result = ParamDefsParse(interp, methodName, args, XOTCL_DISALLOWED_ARG_METHOD_PARAMETER, &parsedParam); } if (result != TCL_OK) { return result; @@ -12099,7 +12100,7 @@ Tcl_AppendToObj(fullParamObj, ObjStr(objPtr), -1); INCR_REF_COUNT(fullParamObj); result = ParamParse(interp, "valuecheck", fullParamObj, - XOTCL_ARG_METHOD_PARAMETER /* allowed options */, + XOTCL_DISALLOWED_ARG_VALUEECHECK /* disallowed options */, paramPtr, &possibleUnknowns, &plainParams); if (result == TCL_OK) { TclFreeIntRep(objPtr); @@ -12235,7 +12236,7 @@ INCR_REF_COUNT(rawConfArgs); /* Parse the string representation to obtain the internal representation */ - result = ParamDefsParse(interp, methodName, rawConfArgs, XOTCL_ARG_OBJECT_PARAMETER, parsedParamPtr); + result = ParamDefsParse(interp, methodName, rawConfArgs, XOTCL_DISALLOWED_ARG_OBJECT_PARAMETER, parsedParamPtr); if (result == TCL_OK && RUNTIME_STATE(interp)->cacheInterface) { XOTclParsedParam *ppDefPtr = NEW(XOTclParsedParam); ppDefPtr->paramDefs = parsedParamPtr->paramDefs; @@ -12334,15 +12335,15 @@ */ Tcl_PushCallFrame(interp, framePtr, obj->nsPtr, FRAME_IS_XOTCL_OBJECT); - XOTcl_PushFrameSetCd(obj); + XOTcl_PushFrameSetCd(obj); /* just set client data */ if (paramPtr->flags & XOTCL_ARG_INITCMD) { result = Tcl_EvalObjEx(interp, newValue, TCL_EVAL_DIRECT); - } else { + } else /* must be XOTCL_ARG_METHOD */ { result = callMethod((ClientData) obj, interp, paramPtr->nameObj, 2+(paramPtr->nrArgs), &newValue, 0); } - Tcl_PopCallFrame(interp); + Tcl_PopCallFrame(interp); /* pop previously stacked frame for eval context */ /*fprintf(stderr, "XOTclOConfigureMethod_ attribute %s evaluated %s => (%d)\n", ObjStr(paramPtr->nameObj), ObjStr(newValue), result);*/ @@ -12570,6 +12571,7 @@ Tcl_Obj **argv, **nextArgv, *resultObj; int i, start = 1, argc, nextArgc, normalArgs, result = TCL_OK, isdasharg = NO_DASH; char *methodName, *nextMethodName; + #if 0 /* if we got a single argument, try to split it (unless it starts * with our magic chars) to distinguish between Index: generic/xotclInt.h =================================================================== diff -u -rc6066a15de738754028991b2b57b8f1d5a1cccaa -r5524b83ed5dda30e55f7a02e4c22d26783688954 --- generic/xotclInt.h (.../xotclInt.h) (revision c6066a15de738754028991b2b57b8f1d5a1cccaa) +++ generic/xotclInt.h (.../xotclInt.h) (revision 5524b83ed5dda30e55f7a02e4c22d26783688954) @@ -356,13 +356,20 @@ /* flags for XOTclParams */ #define XOTCL_ARG_REQUIRED 0x0001 -#define XOTCL_ARG_SUBST_DEFAULT 0x0002 -#define XOTCL_ARG_INITCMD 0x0004 -#define XOTCL_ARG_METHOD 0x0008 -#define XOTCL_ARG_NOARG 0x0010 +#define XOTCL_ARG_MULTIVALUED 0x0002 +#define XOTCL_ARG_NOARG 0x0004 +#define XOTCL_ARG_SUBST_DEFAULT 0x0010 +#define XOTCL_ARG_INITCMD 0x0020 +#define XOTCL_ARG_METHOD 0x0040 #define XOTCL_ARG_RELATION 0x0100 -#define XOTCL_ARG_MULTIVALUED 0x0200 +#define XOTCL_ARG_SWITCH 0x0200 +/* disallowed options */ +#define XOTCL_DISALLOWED_ARG_METHOD_PARAMETER (XOTCL_ARG_METHOD|XOTCL_ARG_INITCMD|XOTCL_ARG_RELATION) +#define XOTCL_DISALLOWED_ARG_OBJECT_PARAMETER 0 +#define XOTCL_DISALLOWED_ARG_VALUEECHECK (XOTCL_ARG_SUBST_DEFAULT|XOTCL_ARG_METHOD|XOTCL_ARG_INITCMD|XOTCL_ARG_RELATION|XOTCL_ARG_SWITCH) + + /* method types */ #define XOTCL_METHODTYPE_ALIAS 0x0001 #define XOTCL_METHODTYPE_SCRIPTED 0x0002 @@ -372,9 +379,6 @@ #define XOTCL_METHODTYPE_OTHER 0x0100 #define XOTCL_METHODTYPE_BUILTIN XOTCL_METHODTYPE_ALIAS|XOTCL_METHODTYPE_SETTER|XOTCL_METHODTYPE_FORWARDER|XOTCL_METHODTYPE_OBJECT|XOTCL_METHODTYPE_OTHER -/* disallowed options */ -#define XOTCL_ARG_METHOD_PARAMETER (XOTCL_ARG_RELATION) /* maybe add ARG_INITCMD */ -#define XOTCL_ARG_OBJECT_PARAMETER 0 /* flags for parseContext */ #define XOTCL_PC_MUST_DECR 0x0001 Index: tests/parameters.xotcl =================================================================== diff -u -r4a478eb598eea7cc8dec70222777d114c55f1ff8 -r5524b83ed5dda30e55f7a02e4c22d26783688954 --- tests/parameters.xotcl (.../parameters.xotcl) (revision 4a478eb598eea7cc8dec70222777d114c55f1ff8) +++ tests/parameters.xotcl (.../parameters.xotcl) (revision 5524b83ed5dda30e55f7a02e4c22d26783688954) @@ -24,6 +24,35 @@ ? {::xotcl::valuecheck integer,multivalued [list 1 2 3 a]} 0 ? {::xotcl::valuecheck in1 aaa} {invalid value constraints "in1"} +# +# parameter options +# required +# optional +# multivalued +# noarg +# arg= +# +# substdefault: if no value given, subst on default (result is substituted value); for scripted/c methods/obj parm +# initcmd: evaluate body in an xotcl nonleaf frame, called via configure +# (example: last arg on create) +# method call specified method in an xotcl nonleaf frame, called via configure; +# specified value is the first argument unless "noarg" is used +# (example: -noinit). +# +# parameter type multivalued required noarg arg= valueCheck methodParm objectParm +# substdefault NO NO NO NO NO YES YES (autmatically set by -parameter on []} +# initcmd NO YES NO NO NO NO/POSSIBLE YES +# method NO YES YES YES NO NO/POSSIBLE YES +# +# relation NO YES NO YES NO NO YES +# +# switch NO NO NO NO NO YES YES +# integer YES YES NO NO YES YES YES +# boolean YES YES NO NO YES YES YES +# object YES YES NO NO YES YES YES +# class YES YES NO NO YES YES YES +# userdefined YES YES NO YES YES YES YES + ####################################################### # objectparameter ####################################################### @@ -222,21 +251,27 @@ return $s-$literal-$c-$d } -? {d1 bar -c 1} {::d1-[self]-1-1} "substdefault on method" +? {d1 bar -c 1} {::d1-[self]-1-1} "substdefault in method parameter" Class create Bar -superclass D -parameter { {s "[self]"} {literal "\\[self\\]"} {c "[my info class]"} - {d "$d"} + {d "literal $d"} + {switch:switch} } Bar create bar1 #puts stderr [bar1 objectparameter] -? {subst {[bar1 s]-[bar1 literal]-[bar1 c]-[bar1 d]}} \ - {::bar1-[self]-::Bar-$d} \ - "substdefault on object" +? {subst {[bar1 s]-[bar1 literal]-[bar1 c]-[bar1 d]-[bar1 switch]}} \ + {::bar1-[self]-::Bar-literal $d-0} \ + "substdefault and switch in object parameter 1" +Bar create bar2 -switch +? {subst {[bar2 s]-[bar2 literal]-[bar2 c]-[bar2 d]-[bar2 switch]}} \ + {::bar2-[self]-::Bar-literal $d-1} \ + "substdefault and switch in object parameter 2" + # Observations: # 1) syntax for "-parameter" and method parameter is quite different. # it would be nice to be able to specify the objparameters in Index: tests/slottest.xotcl =================================================================== diff -u -r4ce2a0659cf44b3dbb7262f63fadb3333c968751 -r5524b83ed5dda30e55f7a02e4c22d26783688954 --- tests/slottest.xotcl (.../slottest.xotcl) (revision 4ce2a0659cf44b3dbb7262f63fadb3333c968751) +++ tests/slottest.xotcl (.../slottest.xotcl) (revision 5524b83ed5dda30e55f7a02e4c22d26783688954) @@ -34,6 +34,7 @@ # x {set x 1} # y {incr ::hu} # z {my trace add variable z read T1}} + Class C -slots { Attribute create x -initcmd {set x 1} Attribute create y -initcmd {incr ::hu}