Index: generic/predefined.h =================================================================== diff -u -rbedcf64642123d38ace4f5117e2b4b99fe9a0e06 -r5556c6d63ea6f4d90705386490253530f0272b57 --- generic/predefined.h (.../predefined.h) (revision bedcf64642123d38ace4f5117e2b4b99fe9a0e06) +++ generic/predefined.h (.../predefined.h) (revision 5556c6d63ea6f4d90705386490253530f0272b57) @@ -75,27 +75,29 @@ "::xotcl::MetaSlot create ::xotcl::Slot\n" "::xotcl::MetaSlot invalidateobjectparameter\n" "::xotcl::Object instproc objectparameter {} {\n" -"set arg_list [list]\n" +"set parameterdefinitions [list]\n" "set slots [::xotcl::objectInfo slotobjects [self]]\n" "foreach slot $slots {\n" -"set arg \"-[namespace tail $slot]\"\n" +"set parameterdefinition \"-[namespace tail $slot]\"\n" "set opts [list]\n" "if {[$slot exists required] && [$slot required]} {\n" "lappend opts required}\n" "if {[$slot exists type]} {\n" "lappend opts [$slot type]}\n" "if {[$slot exists default]} {\n" -"set default [$slot set default]\n" -"if {[string match {*\\[*\\]*} $default] || [string first $default {$}] > -1} {\n" -"lappend opts substdefault}} elseif [info exists default] {\n" -"unset default}\n" +"set arg [$slot set default]\n" +"if {[string match {*\\[*\\]*} $arg] || [string first $arg {$}] > -1} {\n" +"lappend opts substdefault}} elseif {[$slot exists initcmd]} {\n" +"set arg [$slot set initcmd]\n" +"lappend opts initcmd}\n" "if {[llength $opts] > 0} {\n" -"set arg \"$arg:[join $opts ,]\"}\n" -"if {[info exists default]} {\n" -"lappend arg $default}\n" -"lappend arg_list $arg}\n" -"lappend arg_list args\n" -"return $arg_list}\n" +"append parameterdefinition :[join $opts ,]}\n" +"if {[info exists arg]} {\n" +"lappend parameterdefinition $arg\n" +"unset arg}\n" +"lappend parameterdefinitions $parameterdefinition}\n" +"lappend parameterdefinitions args\n" +"return $parameterdefinitions}\n" "proc createBootstrapAttributeSlots {class definitions} {\n" "if {![::xotcl::is ${class}::slot object]} {\n" "::xotcl::Object create ${class}::slot}\n" Index: generic/predefined.xotcl =================================================================== diff -u -rbedcf64642123d38ace4f5117e2b4b99fe9a0e06 -r5556c6d63ea6f4d90705386490253530f0272b57 --- generic/predefined.xotcl (.../predefined.xotcl) (revision bedcf64642123d38ace4f5117e2b4b99fe9a0e06) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision 5556c6d63ea6f4d90705386490253530f0272b57) @@ -189,13 +189,13 @@ # Provide the a slot based mechanism for building an object # configuration interface from slot definitions ::xotcl::Object instproc objectparameter {} { - set arg_list [list] + set parameterdefinitions [list] # don't call [my info slotobjects], since filters on [self] # modifying the result (such as in the regression test) will cause # problems. set slots [::xotcl::objectInfo slotobjects [self]] foreach slot $slots { - set arg "-[namespace tail $slot]" + set parameterdefinition "-[namespace tail $slot]" set opts [list] if {[$slot exists required] && [$slot required]} { @@ -205,25 +205,27 @@ lappend opts [$slot type] } if {[$slot exists default]} { - set default [$slot set default] - if {[string match {*\[*\]*} $default] || [string first $default {$}] > -1} { + set arg [$slot set default] + if {[string match {*\[*\]*} $arg] || [string first $arg {$}] > -1} { lappend opts substdefault } - } elseif [info exists default] { - unset default + } elseif {[$slot exists initcmd]} { + set arg [$slot set initcmd] + lappend opts initcmd } if {[llength $opts] > 0} { - set arg "$arg:[join $opts ,]" + append parameterdefinition :[join $opts ,] } - if {[info exists default]} { - lappend arg $default + if {[info exists arg]} { + lappend parameterdefinition $arg + unset arg } - lappend arg_list $arg + lappend parameterdefinitions $parameterdefinition } # todo: why do we need "args"? temporary solution? - lappend arg_list args - #puts stderr "*** args spec for [self]: $arg_list" - return $arg_list + lappend parameterdefinitions args + #puts stderr "*** parameter definition for [self]: $parameterdefinitions" + return $parameterdefinitions } # use low level interface for defining slot values. Normally, this is Index: generic/xotcl.c =================================================================== diff -u -rbedcf64642123d38ace4f5117e2b4b99fe9a0e06 -r5556c6d63ea6f4d90705386490253530f0272b57 --- generic/xotcl.c (.../xotcl.c) (revision bedcf64642123d38ace4f5117e2b4b99fe9a0e06) +++ generic/xotcl.c (.../xotcl.c) (revision 5556c6d63ea6f4d90705386490253530f0272b57) @@ -4615,13 +4615,13 @@ TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); if (initCmd) { char *cmd = ObjStr(initCmd); - fprintf(stderr, "----- we have an initcmd %s\n", cmd); + /*fprintf(stderr, "----- we have an initcmd %s\n", cmd);*/ if (*cmd) { #if !defined(TCL85STACK) CallStackPush(interp, obj, NULL, 0, XOTCL_CSC_TYPE_PLAIN); /*allow to call self*/ #endif - fprintf(stderr,"!!!! evaluating '%s'\n", cmd); + /*fprintf(stderr,"!!!! evaluating '%s'\n", cmd);*/ rc = Tcl_EvalObjEx(interp, initCmd, TCL_EVAL_DIRECT); #if !defined(TCL85STACK) CallStackPop(interp, NULL); @@ -5620,6 +5620,8 @@ ifPtr->flags |= XOTCL_ARG_REQUIRED; } else if (strncmp(option,"substdefault",length) == 0) { ifPtr->flags |= XOTCL_ARG_SUBST_DEFAULT; + } else if (strncmp(option,"initcmd",length) == 0) { + ifPtr->flags |= XOTCL_ARG_INITCMD; } else if (strncmp(option,"switch",length) == 0) { ifPtr->nrargs = 0; ifPtr->converter = convertToSwitch; @@ -5648,7 +5650,7 @@ ifPtr->converter = convertToRelation; ifPtr->type = "tclobj"; } else { - fprintf(stderr, "**** unknown argument option: def %s, option '%s' (%d)\n",ifPtr->name,option,length); + fprintf(stderr, "**** unknown parameter option: def %s, option '%s' (%d)\n",ifPtr->name,option,length); } return TCL_OK; } @@ -10164,6 +10166,7 @@ /* 2. continue parsing the actual args passed */ result = canonicalNonpositionalArgs(&pc, interp, nonposArgs, "configure", objc, objv); if (result != TCL_OK) { + XOTcl_PopFrame(interp, obj); parseContextRelease(&pc); goto configure_exit; } @@ -10201,24 +10204,36 @@ * through a mixin or filter) */ if (oldValue == NULL) { + int setvalue = 1; /* TODO: should not be needed */ /* TODO: should not be relation handling here and subst handling in canonicalNonpositionalArgs(); we do subst handling here due to reference counting */ - + if (ifPtr->flags & XOTCL_ARG_SUBST_DEFAULT) { result = SubstValue(interp, obj, &newValue); + fprintf(stderr, "XOTclOConfigureMethod: attribute %s substituted value => %p '%s'\n", argName, + newValue,ObjStr(newValue)); if (result != TCL_OK) { parseContextRelease(&pc); goto configure_exit; } - fprintf(stderr, "substituted value for attribute %s => %p '%s'\n", argName, - newValue,ObjStr(newValue)); - } + } else if (ifPtr->flags & XOTCL_ARG_INITCMD) { + result = Tcl_EvalObjEx(interp, newValue, TCL_EVAL_DIRECT); + /*fprintf(stderr, "XOTclOConfigureMethod_ attribute %s evaluated %s => (%d)\n", argName, + ObjStr(newValue), result);*/ + if (result != TCL_OK) { + parseContextRelease(&pc); + goto configure_exit; + } + setvalue = 0; + } + if (setvalue) { #if defined(CONFIGURE_ARGS_TRACE) - fprintf(stderr, "*** %s SET %s '%s'\n",objectName(obj),argName, ObjStr(newValue)); + fprintf(stderr, "*** %s SET %s '%s'\n",objectName(obj),argName, ObjStr(newValue)); #endif - Tcl_ObjSetVar2(interp, argNameObj, NULL, newValue, TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); + Tcl_ObjSetVar2(interp, argNameObj, NULL, newValue, TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); + } } else { #if defined(CONFIGURE_ARGS_TRACE) fprintf(stderr, "*** no need to set, we have already '%s' for arg '%s'\n",ObjStr(oldValue),argName); @@ -12144,6 +12159,9 @@ if (result == TCL_OK) { result = XOTclRelationCmd(interp, self, relIdx, pcPtr->objv[i]); fprintf(stderr, " relationcmd %s %d %s returned (%d)\n", objectName(self), relIdx, ObjStr(pcPtr->objv[i]), result); + if (result != TCL_OK) { + return result; + } /* TODO: For the time being, we fall back to an unknown value * so that we do not obtain proc-local (through InitArgsAndLocals()) * or object variables (through XOTclOConfigureMethod) from relational commands @@ -12253,7 +12271,8 @@ * list representation for 'args' at this point. */ if (elts > 1) { - memcpy(pcPtr->objv+i,objv+pcPtr->lastobjc,sizeof(Tcl_Obj *)*elts); + /* TODO: this cannot stay like this */ + memcpy(pcPtr->objv+i, objv+pcPtr->lastobjc, sizeof(Tcl_Obj *)*elts); pcPtr->objc = pcPtr->objc + elts - 1; } } Index: generic/xotclInt.h =================================================================== diff -u -rbedcf64642123d38ace4f5117e2b4b99fe9a0e06 -r5556c6d63ea6f4d90705386490253530f0272b57 --- generic/xotclInt.h (.../xotclInt.h) (revision bedcf64642123d38ace4f5117e2b4b99fe9a0e06) +++ generic/xotclInt.h (.../xotclInt.h) (revision 5556c6d63ea6f4d90705386490253530f0272b57) @@ -428,6 +428,7 @@ #define XOTCL_ARG_REQUIRED 0x0001 #define XOTCL_ARG_SUBST_DEFAULT 0x0002 +#define XOTCL_ARG_INITCMD 0x0004 #define XOTclObjectSetClass(obj) \ (obj)->flags |= XOTCL_IS_CLASS Index: tests/slottest.xotcl =================================================================== diff -u -r43e8ea0de59e32655b41cbd6c8a47acf8ada443a -r5556c6d63ea6f4d90705386490253530f0272b57 --- tests/slottest.xotcl (.../slottest.xotcl) (revision 43e8ea0de59e32655b41cbd6c8a47acf8ada443a) +++ tests/slottest.xotcl (.../slottest.xotcl) (revision 5556c6d63ea6f4d90705386490253530f0272b57) @@ -36,17 +36,6 @@ package require xotcl::serializer -#proc ? {cmd expected} { -# set r [eval $cmd] -# if {$r ne $expected} {error "$cmd returned '$r' ne '$expected'"} -#} - -# proc t {cmd {txt ""}} { -# set n 1000 -# #set ms [lindex [time [list time $cmd $n] 10] 0] -# set ms [lindex [time [list time $cmd $n] 5] 0] -# puts "[format %7.4f [expr {$ms*1.0/$n}]]ms for [format %-30s $cmd] ($txt)" -# } ####################################################### # testing __initcmds set ::hu 0 @@ -61,6 +50,7 @@ Attribute y -initcmd {incr ::hu} Attribute z -initcmd {my trace add variable z read T1} } + C create c1 ? {c1 info vars x} "" ? {c1 x} "1"