Index: TODO =================================================================== diff -u -r515bb4c0ed4a2dad74c4a29c940b57a3e911845d -r9dd5024eae672704fae601972a3111ab221750e7 --- TODO (.../TODO) (revision 515bb4c0ed4a2dad74c4a29c940b57a3e911845d) +++ TODO (.../TODO) (revision 9dd5024eae672704fae601972a3111ab221750e7) @@ -4490,15 +4490,17 @@ other traces for the same operations. - extended regression test -- added partly implementation for slots with traces+types for classes +- added implementation for slots with traces+types for classes +- exception for incorrect defaults are thrown during slot creation +- extended nsf::is, added parameter + * ?-configure? -- accept configure paramter options + * ?-name /name/? -- provide a parameter name for error message +- simplified nx.tcl by using new nsf::is +- extended regression test ======================================================================== TODO: -- # configure-trace-class-type (in cget.test) - # (a) the error message would contain the lower-level message - # (b) the error would be generated earlier (not on object creation) - # (c) the error should not be generated when an actual value is provided -- add configure-trace-object-type + - fix property inheritance in traits (nx-traits.tcl) - maybe remove unneeded values, align naming in enumeration of first arg of *::info::objectparameter and *::info::method Index: generic/nsf.c =================================================================== diff -u -r515bb4c0ed4a2dad74c4a29c940b57a3e911845d -r9dd5024eae672704fae601972a3111ab221750e7 --- generic/nsf.c (.../nsf.c) (revision 515bb4c0ed4a2dad74c4a29c940b57a3e911845d) +++ generic/nsf.c (.../nsf.c) (revision 9dd5024eae672704fae601972a3111ab221750e7) @@ -299,7 +299,9 @@ NsfObject *object, int processFlags, NsfParamDefs *paramDefs, Tcl_Obj *methodNameObj, int objc, Tcl_Obj *CONST objv[]); static int ParameterCheck(Tcl_Interp *interp, Tcl_Obj *paramObjPtr, Tcl_Obj *valueObj, - const char *argNamePrefix, int doCheckArguments, Nsf_Param **paramPtrPtr); + const char *argNamePrefix, int doCheckArguments, + int isNamed, int doConfigureParameter, + Nsf_Param **paramPtrPtr); static void ParamDefsRefCountIncr(NsfParamDefs *paramDefs); static void ParamDefsRefCountDecr(NsfParamDefs *paramDefs); static int ParamSetFromAny(Tcl_Interp *interp, register Tcl_Obj *objPtr); @@ -10322,7 +10324,7 @@ if (paramDefs && paramDefs->returns) { Tcl_Obj *valueObj = Tcl_GetObjResult(interp); result = ParameterCheck(interp, paramDefs->returns, valueObj, "return-value:", - rst->doCheckResults, NULL); + rst->doCheckResults, 0, 0, NULL); } } else { /*fprintf(stderr, "We have no cmdPtr in cscPtr %p %s", cscPtr, ObjectName(object)); @@ -19680,17 +19682,27 @@ /* cmd is NsfIsCmd { - {-argName "-complain"} + {-argName "-complain" -nrargs 0} + {-argName "-configure" -nrargs 0} + {-argName "-name" -required 0} {-argName "constraint" -required 1 -type tclobj} {-argName "value" -required 1 -type tclobj} -} +} {-nxdoc 1} */ static int -NsfIsCmd(Tcl_Interp *interp, int withComplain, Tcl_Obj *constraintObj, Tcl_Obj *valueObj) { +NsfIsCmd(Tcl_Interp *interp, + int withComplain, + int doConfigureParameter, + CONST char *name, + Tcl_Obj *constraintObj, + Tcl_Obj *valueObj) { Nsf_Param *paramPtr = NULL; int result; - result = ParameterCheck(interp, constraintObj, valueObj, "value:", 1, ¶mPtr); + result = ParameterCheck(interp, constraintObj, valueObj, + name ? name : "value:", 1, (name != NULL), + doConfigureParameter, + ¶mPtr); if (paramPtr == NULL) { /* @@ -21922,6 +21934,7 @@ ParamSetFromAny2( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ const char *varNamePrefix, /* shows up as varName in error message */ + int configureParameter, /* allow object parameters */ register Tcl_Obj *objPtr) /* The object to convert. */ { Tcl_Obj *fullParamObj = Tcl_NewStringObj(varNamePrefix, -1); @@ -21931,12 +21944,11 @@ paramWrapperPtr->paramPtr = ParamsNew(1); paramWrapperPtr->refCount = 1; paramWrapperPtr->canFree = 0; - /*fprintf(stderr, "allocating %p\n", paramWrapperPtr->paramPtr);*/ Tcl_AppendLimitedToObj(fullParamObj, ObjStr(objPtr), -1, INT_MAX, NULL); INCR_REF_COUNT(fullParamObj); result = ParamParse(interp, NsfGlobalObjs[NSF_VALUECHECK], fullParamObj, - NSF_DISALLOWED_ARG_VALUECHECK /* disallowed options */, + configureParameter ? NSF_DISALLOWED_ARG_OBJECT_PARAMETER : NSF_DISALLOWED_ARG_VALUECHECK, paramWrapperPtr->paramPtr, &possibleUnknowns, &plainParams, &nrNonposArgs); /* @@ -21976,7 +21988,7 @@ Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr) /* The object to convert. */ { - return ParamSetFromAny2(interp, "value:", objPtr); + return ParamSetFromAny2(interp, "value:", 0, objPtr); } /* @@ -22132,7 +22144,9 @@ static int ParameterCheck(Tcl_Interp *interp, Tcl_Obj *paramObjPtr, Tcl_Obj *valueObj, - const char *argNamePrefix, int doCheckArguments, Nsf_Param **paramPtrPtr) { + const char *argNamePrefix, int doCheckArguments, + int isNamed, int doConfigureParameter, + Nsf_Param **paramPtrPtr) { Nsf_Param *paramPtr; NsfParamWrapper *paramWrapperPtr; Tcl_Obj *outObjPtr = NULL; @@ -22147,10 +22161,10 @@ } else { /* * We could use in principle Tcl_ConvertToType(..., ¶mObjType) instead - * of checking the type manually, be we want to pass the argNamePrefix + * of checking the type manually, but we want to pass the argNamePrefix * explicitly. */ - result = ParamSetFromAny2(interp, argNamePrefix, paramObjPtr); + result = ParamSetFromAny2(interp, argNamePrefix, doConfigureParameter, paramObjPtr); if (result == TCL_OK) { paramWrapperPtr = (NsfParamWrapper *) paramObjPtr->internalRep.twoPtrValue.ptr1; } else { @@ -22160,6 +22174,10 @@ paramPtr = paramWrapperPtr->paramPtr; if (paramPtrPtr) *paramPtrPtr = paramPtr; + if (isNamed) { + paramPtr->flags &= ~NSF_ARG_UNNAMED; + } + result = ArgumentCheck(interp, valueObj, paramPtr, doCheckArguments, &flags, &checkedData, &outObjPtr); /*fprintf(stderr, "ParameterCheck paramPtr %p final refCount of wrapper %d can free %d flags %.6x\n", paramPtr, paramWrapperPtr->refCount, paramWrapperPtr->canFree, flags);*/ Index: generic/nsfAPI.decls =================================================================== diff -u -rd79efb10b92ad2045196990af50bc042e60b88f4 -r9dd5024eae672704fae601972a3111ab221750e7 --- generic/nsfAPI.decls (.../nsfAPI.decls) (revision d79efb10b92ad2045196990af50bc042e60b88f4) +++ generic/nsfAPI.decls (.../nsfAPI.decls) (revision 9dd5024eae672704fae601972a3111ab221750e7) @@ -63,8 +63,11 @@ {-argName "name" -required 1} {-argName "args" -type allargs} } {-nxdoc 1} + cmd is NsfIsCmd { {-argName "-complain" -nrargs 0} + {-argName "-configure" -nrargs 0} + {-argName "-name" -required 0} {-argName "constraint" -required 1 -type tclobj} {-argName "value" -required 1 -type tclobj} } {-nxdoc 1} Index: generic/nsfAPI.h =================================================================== diff -u -rd79efb10b92ad2045196990af50bc042e60b88f4 -r9dd5024eae672704fae601972a3111ab221750e7 --- generic/nsfAPI.h (.../nsfAPI.h) (revision d79efb10b92ad2045196990af50bc042e60b88f4) +++ generic/nsfAPI.h (.../nsfAPI.h) (revision 9dd5024eae672704fae601972a3111ab221750e7) @@ -384,7 +384,7 @@ static int NsfDispatchCmd(Tcl_Interp *interp, NsfObject *object, int withIntrinsic, int withSystem, Tcl_Obj *command, int nobjc, Tcl_Obj *CONST nobjv[]); static int NsfFinalizeCmd(Tcl_Interp *interp, int withKeepvars); static int NsfInterpObjCmd(Tcl_Interp *interp, CONST char *name, int objc, Tcl_Obj *CONST objv[]); -static int NsfIsCmd(Tcl_Interp *interp, int withComplain, Tcl_Obj *constraint, Tcl_Obj *value); +static int NsfIsCmd(Tcl_Interp *interp, int withComplain, int withConfigure, CONST char *withName, Tcl_Obj *constraint, Tcl_Obj *value); static int NsfMethodAliasCmd(Tcl_Interp *interp, NsfObject *object, int withPer_object, CONST char *methodName, int withFrame, Tcl_Obj *cmdName); static int NsfMethodAssertionCmd(Tcl_Interp *interp, NsfObject *object, int assertionsubcmd, Tcl_Obj *arg); static int NsfMethodCreateCmd(Tcl_Interp *interp, NsfObject *object, int withInner_namespace, int withPer_object, NsfObject *withReg_object, Tcl_Obj *methodName, Tcl_Obj *arguments, Tcl_Obj *body, Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition); @@ -1305,11 +1305,13 @@ method_definitions[NsfIsCmdIdx].nrParameters, 0, NSF_ARGPARSE_BUILTIN, &pc) == TCL_OK)) { int withComplain = (int )PTR2INT(pc.clientData[0]); - Tcl_Obj *constraint = (Tcl_Obj *)pc.clientData[1]; - Tcl_Obj *value = (Tcl_Obj *)pc.clientData[2]; + int withConfigure = (int )PTR2INT(pc.clientData[1]); + CONST char *withName = (CONST char *)pc.clientData[2]; + Tcl_Obj *constraint = (Tcl_Obj *)pc.clientData[3]; + Tcl_Obj *value = (Tcl_Obj *)pc.clientData[4]; assert(pc.status == 0); - return NsfIsCmd(interp, withComplain, constraint, value); + return NsfIsCmd(interp, withComplain, withConfigure, withName, constraint, value); } else { return TCL_ERROR; @@ -2817,8 +2819,10 @@ {"name", NSF_ARG_REQUIRED, 1, Nsf_ConvertToString, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}, {"args", 0, 1, ConvertToNothing, NULL,NULL,"allargs",NULL,NULL,NULL,NULL,NULL}} }, -{"::nsf::is", NsfIsCmdStub, 3, { +{"::nsf::is", NsfIsCmdStub, 5, { {"-complain", 0, 0, Nsf_ConvertToString, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}, + {"-configure", 0, 0, Nsf_ConvertToString, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}, + {"-name", 0, 1, Nsf_ConvertToString, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}, {"constraint", NSF_ARG_REQUIRED, 1, Nsf_ConvertToTclobj, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}, {"value", NSF_ARG_REQUIRED, 1, Nsf_ConvertToTclobj, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}} }, Index: library/nx/nx.tcl =================================================================== diff -u -r515bb4c0ed4a2dad74c4a29c940b57a3e911845d -r9dd5024eae672704fae601972a3111ab221750e7 --- library/nx/nx.tcl (.../nx.tcl) (revision 515bb4c0ed4a2dad74c4a29c940b57a3e911845d) +++ library/nx/nx.tcl (.../nx.tcl) (revision 9dd5024eae672704fae601972a3111ab221750e7) @@ -1658,23 +1658,9 @@ error "object $object has already an instance variable named '${:name}'" } set options [:getParameterOptions -withMultiplicity true] - # - # TODO: How to handle options selection for ::nsf::is? - # - set options [lsearch -all -inline -not -regexp $options [join { - slotassign - slotinitialize - positional - convert - substdefault - noconfig - initcmd - cmd - required - } |]] - + if {[llength $options]} { - ::nsf::is -complain [join $options ,] $value + ::nsf::is -configure -complain -name ${:name}: [join $options ,] $value } set restore [:removeTraces $object *] @@ -1797,6 +1783,7 @@ } :makeAccessor if {${:per-object} && [info exists :default]} { + puts stderr "reconfigure calls setCheckedInstVar" :setCheckedInstVar -nocomplain=[info exists :nocomplain] ${:domain} ${:default} } if {[::nsf::is class ${:domain}]} { @@ -1813,6 +1800,18 @@ return $spec } + ::nx::VariableSlot protected method checkDefault {} { + if {![info exists :default]} {return} + set options [:getParameterOptions -withMultiplicity true] + if {[llength $options] > 0} { + if {[catch {::nsf::is -complain -configure -name ${:name}: [join $options ,] ${:default}} errorMsg]} { + #puts stderr "**** destroy [self] - $errorMsg" + :destroy + error $errorMsg + } + } + } + ::nx::VariableSlot protected method init {} { #puts "VariableSlot [self] ${:incremental} && ${:accessor} && ${:multiplicity} incremental ${:incremental}" if {${:incremental}} { @@ -1821,6 +1820,7 @@ } next :makeAccessor + :checkDefault :handleTraces } @@ -2005,6 +2005,7 @@ #puts "... slotless variable $spec" set isSwitch [regsub {\mswitch\M} $parameterOptions boolean parameterOptions] + if {[info exists defaultValue]} { if {[info exists :$name] && !$nocomplain} { error "object [self] has already an instance variable named '$name'" Index: tests/cget.test =================================================================== diff -u -r515bb4c0ed4a2dad74c4a29c940b57a3e911845d -r9dd5024eae672704fae601972a3111ab221750e7 --- tests/cget.test (.../cget.test) (revision 515bb4c0ed4a2dad74c4a29c940b57a3e911845d) +++ tests/cget.test (.../cget.test) (revision 9dd5024eae672704fae601972a3111ab221750e7) @@ -1,13 +1,11 @@ # -*- Tcl -*- package req nx - package require nx::test -namespace import ::nx::* # # The first test set checks just the basic behavior: # -Test case cget-simple { +nx::Test case cget-simple { nx::Class create Person { :property famnam:required @@ -63,8 +61,8 @@ # methods "assign" and "get". # -Test parameter count 1 -Test case cget-via-slot { +nx::Test parameter count 1 +nx::Test case cget-via-slot { nx::Class create C { @@ -124,7 +122,7 @@ # The third test set checks method binding to parameter: # All cmds are supposed to return resonable values. # -Test case cget-parameter-methods { +nx::Test case cget-parameter-methods { nx::Class create C { :property {foo:alias,method=m0 {1 2 3}} :property {{bar:forward,method=%self m1 a b c %method} bar1} @@ -178,7 +176,7 @@ # The fourth test set checks performance of "cget" and "configure". # nx::Test parameter count 10000 -Test case cget-performance { +nx::Test case cget-performance { nx::Class create Person { :property famnam:required @@ -222,8 +220,8 @@ } -nx::Test parameter count 10 -Test case configure-trace-class { +nx::Test parameter count 1 +nx::Test case configure-trace-class { # # class case with no default @@ -261,7 +259,7 @@ ? {c2 cget -q} "102" } -Test case configure-trace-object { +nx::Test case configure-trace-object { # # object case with no default # @@ -327,30 +325,85 @@ # # class case with type and default # - puts stderr ====1 - C property {q:integer aaa} { + + ? {C property {q:integer aaa} { set :valuechangedcmd { #puts stderr "C.q valuechangedcmd $obj $var +1" ::nsf::var::set $obj $var [expr [list [::nsf::var::set $obj $var] + 1]] } - } - # TODO: it would be nicer, if - # (a) the error message would contain the lower-level message - # (b) the error would be generated earlier (not on object creation) - # (c) the error should not be generated when an actual value is provided - ? {C create c2} "objectparameter: ::C::slot::q getParameterSpec returned error" - ? {C create c2 -q 111} "objectparameter: ::C::slot::q getParameterSpec returned error" + }} {expected integer but got "aaa" for parameter "q"} - ? {C property {q:integer 100} { + # slot should no exist + ? {C info slots q} "" + + ? {C property {q:integer 99} { set :valuechangedcmd { #puts stderr "C.q valuechangedcmd $obj $var +1" ::nsf::var::set $obj $var [expr [list [::nsf::var::set $obj $var] + 1]] } }} "" - C create c2 - + + # slot should exist + ? {C info slots q} "::C::slot::q" + + ? {C create c2 -q 111} ::c2 ? {c2 eval {info exists :q}} 1 - ? {c2 cget -q} 100 + + ? {c2 cget -q} 112 ? {c2 configure -q 101} "" ? {c2 cget -q} "102" -} \ No newline at end of file +} + + +nx::Test case configure-trace-object-type { + # + # object case with no default + # + + nx::Object create o + ? {o eval {info exists :A}} 0 + o object property A:integer { + set :valuechangedcmd { + #puts stderr "o.A valuechangedcmd $obj $var +1" + ::nsf::var::set $obj $var [expr [list [::nsf::var::set $obj $var] + 1]] + } + } + # puts [o info object variables A] + # puts [o info variable parameter [o info object variables A]] + # puts [[o info object slots A] getParameterSpec] + + ? {o eval {info exists :A}} 0 + ? {o cget -A} {can't read "A": no such variable} + ? {o configure -A 1} "" + ? {o cget -A} "2" + ? {o configure -A x} {expected integer but got "x" for parameter "-A"} + ? {o cget -A} "2" + + # + # object case with default + # + + ? {o eval {info exists :B}} 0 + ? {o object property {B:integer x} { + #puts stderr "o.B valuechangedcmd $obj $var +1" + set :valuechangedcmd {::nsf::var::set $obj $var [expr [list [::nsf::var::set $obj $var] + 1]]} + }} {expected integer but got "x" for parameter "B"} + ? {o eval {info exists :B}} 0 + + ? {o info object slots B} "" + + ? {o object property {B:integer 1000} { + #puts stderr "o.B valuechangedcmd $obj $var +1" + set :valuechangedcmd {::nsf::var::set $obj $var [expr [list [::nsf::var::set $obj $var] + 1]]} + }} {} + + ? {o info object slots B} {::o::per-object-slot::B} + ? {o eval {info exists :B}} 1 + + ? {o cget -B} 1000 + ? {o configure -B 1001} "" + ? {o cget -B} 1002 + + ? {o configure -B x} {expected integer but got "x" for parameter "-B"} + ? {o cget -B} 1002 +} Index: tests/parameters.test =================================================================== diff -u -ra774481bc677369c7b0f7d1fcf3275ee1afd4fba -r9dd5024eae672704fae601972a3111ab221750e7 --- tests/parameters.test (.../parameters.test) (revision a774481bc677369c7b0f7d1fcf3275ee1afd4fba) +++ tests/parameters.test (.../parameters.test) (revision 9dd5024eae672704fae601972a3111ab221750e7) @@ -2153,7 +2153,7 @@ # set variable with a value checker and an invalid value ? [list [self] object variable y1:int a] {expected integer but got "a"} - ? [list [self] object property [list y2:int b]] {expected integer but got "b"} + ? [list [self] object property [list y2:int b]] {expected integer but got "b" for parameter "y2"} # set variable again, without -nocomplain ? [list [self] object variable x1:int 1] {object ::enterprise has already an instance variable named 'x1'} @@ -2171,7 +2171,7 @@ ? [list [self] object variable -nocomplain xm1:int,1..n {1 2a 3}] \ {invalid value in "1 2a 3": expected integer but got "2a"} ? [list [self] object property -nocomplain [list xm2:int,1..n {1 2a 3}]] \ - {invalid value in "1 2a 3": expected integer but got "2a"} + {invalid value in "1 2a 3": expected integer but got "2a" for parameter "xm2"} # useless definition ? [list [self] object variable dummy:int] \ @@ -2194,7 +2194,7 @@ ? [list [self] object variable -nocomplain r1:range,arg=1-10 11] \ {value '11' of parameter value not between 1 and 10} ? [list [self] object property -nocomplain [list r2:range,arg=1-10 11]] \ - {value '11' of parameter value not between 1 and 10} + {value '11' of parameter r2 not between 1 and 10} # valid value ? [list [self] object variable -nocomplain r1:range,arg=1-10 5] ""