Index: generic/predefined.h =================================================================== diff -u -r3ecb613fe4ef3fd510e73792cdf0764a1d1489ab -rcfee325944ac90fe94485cba109a7e99465073b5 --- generic/predefined.h (.../predefined.h) (revision 3ecb613fe4ef3fd510e73792cdf0764a1d1489ab) +++ generic/predefined.h (.../predefined.h) (revision cfee325944ac90fe94485cba109a7e99465073b5) @@ -259,6 +259,7 @@ "if {$type ne \"\"} {\n" "set objopts [linsert $objopts 0 $type]\n" "set methodopts [linsert $methodopts 0 $type]}\n" +"lappend objopts slot=[self]\n" "if {[llength $objopts] > 0} {\n" "append objparamdefinition :[join $objopts ,]}\n" "if {[llength $methodopts] > 0} {\n" @@ -409,9 +410,9 @@ "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" -":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" +":method assign [list obj var value:$(mparam),multivalued,slot=[self]] {::xotcl::setinstvar $obj $var $value}\n" +":method add [list obj prop value:$(mparam),slot=[self] {pos 0}] {next}} else {\n" +":method assign [list obj var value:$(mparam),slot=[self]] {::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 -r3ecb613fe4ef3fd510e73792cdf0764a1d1489ab -rcfee325944ac90fe94485cba109a7e99465073b5 --- generic/predefined.xotcl (.../predefined.xotcl) (revision 3ecb613fe4ef3fd510e73792cdf0764a1d1489ab) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision cfee325944ac90fe94485cba109a7e99465073b5) @@ -512,6 +512,8 @@ set objopts [linsert $objopts 0 $type] set methodopts [linsert $methodopts 0 $type] } + lappend objopts slot=[self] + if {[llength $objopts] > 0} { append objparamdefinition :[join $objopts ,] } @@ -549,8 +551,6 @@ -noinit:method,optional,noarg \ -volatile:method,optional,noarg \ arg:initcmd,optional - # for the time being, use: - #lappend parameterdefinitions args #puts stderr "*** parameter definition for [self]: $parameterdefinitions" return $parameterdefinitions } @@ -778,12 +778,12 @@ 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} + :method assign [list obj var value:$(mparam),multivalued,slot=[self]] {::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} + :method add [list obj prop value:$(mparam),slot=[self] {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} + :method assign [list obj var value:$(mparam),slot=[self]] {::xotcl::setinstvar $obj $var $value} } } #append __initcmd [:mk_type_checker] Index: generic/xotcl.c =================================================================== diff -u -r985438008a249cdf076309b9b3f0ba517a6f2db9 -rcfee325944ac90fe94485cba109a7e99465073b5 --- generic/xotcl.c (.../xotcl.c) (revision 985438008a249cdf076309b9b3f0ba517a6f2db9) +++ generic/xotcl.c (.../xotcl.c) (revision cfee325944ac90fe94485cba109a7e99465073b5) @@ -5264,6 +5264,7 @@ if (paramPtr->converterName) {DECR_REF_COUNT(paramPtr->converterName);} if (paramPtr->converterArg) {DECR_REF_COUNT(paramPtr->converterArg);} if (paramPtr->paramObj) {DECR_REF_COUNT(paramPtr->paramObj);} + if (paramPtr->slotObj) {DECR_REF_COUNT(paramPtr->slotObj);} } FREE(XOTclParam*, paramsPtr); } @@ -6287,8 +6288,8 @@ static int convertViaCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { Tcl_Obj *ov[5]; int result, oc; - - ov[0] = XOTclGlobalObjects[XOTE_METHOD_PARAMETER_SLOT_OBJ]; + + ov[0] = pPtr->slotObj ? pPtr->slotObj : XOTclGlobalObjects[XOTE_METHOD_PARAMETER_SLOT_OBJ]; ov[1] = pPtr->converterName; ov[2] = pPtr->nameObj; ov[3] = objPtr; @@ -6302,7 +6303,8 @@ result = Tcl_EvalObjv(interp, oc, ov, 0); if (result == TCL_OK) { - *clientData = (ClientData)objPtr; + fprintf(stderr, "convertViaCmd converts %s to '%s'\n", ObjStr(objPtr), ObjStr(Tcl_GetObjResult(interp))); + *clientData = (ClientData)Tcl_GetObjResult(interp); } return result; } @@ -6404,6 +6406,9 @@ return XOTclVarErrMsg(interp, "option type= only allowed for object or class", (char *) NULL); paramPtr->converterArg = Tcl_NewStringObj(option+5, length-5); INCR_REF_COUNT(paramPtr->converterArg); + } else if (length >= 6 && strncmp(option, "slot=", 5) == 0) { + paramPtr->slotObj = Tcl_NewStringObj(option+5, length-5); + INCR_REF_COUNT(paramPtr->slotObj); } else { int i, found = -1; @@ -6421,28 +6426,10 @@ paramPtr->converterArg = Tcl_NewStringObj(stringTypeOpts[i], -1); INCR_REF_COUNT(paramPtr->converterArg); } else { - /* converter defined via method */ - XOTclObject *paramObj; - Tcl_Obj *checker; - XOTclClass *pcl; - Tcl_Command cmd; - - result = GetObjectFromObj(interp, XOTclGlobalObjects[XOTE_METHOD_PARAMETER_SLOT_OBJ], ¶mObj); - if (result != TCL_OK) - return result; - - checker = ParamCheckObj(interp, option, length); - INCR_REF_COUNT(checker); - cmd = ObjectFindMethod(interp, paramObj, ObjStr(checker), &pcl); - - if (cmd == NULL) { - fprintf(stderr, "**** could not find checker method %s defined on %s\n", - ObjStr(checker), objectName(paramObj)); - paramPtr->flags |= XOTCL_ARG_CURRENTLY_UNKNOWN; - /* TODO: for the time being, we do not return an error here */ - } + /* must be a converter defined via method */ + paramPtr->converterName = ParamCheckObj(interp, option, length); + INCR_REF_COUNT(paramPtr->converterName); result = ParamOptionSetConverter(interp, paramPtr, "usertype", convertViaCmd); - paramPtr->converterName = checker; } } @@ -6556,9 +6543,30 @@ goto param_error; } - /* convertToTclobj() is the default converter */ + /* postprocessing the parameter options */ + if (paramPtr->converter == NULL) { + /* convertToTclobj() is the default converter */ paramPtr->converter = convertToTclobj; + } else if (paramPtr->converter == convertViaCmd) { + XOTclObject *paramObj; + XOTclClass *pcl; + Tcl_Command cmd; + + result = GetObjectFromObj(interp, paramPtr->slotObj ? paramPtr->slotObj : + XOTclGlobalObjects[XOTE_METHOD_PARAMETER_SLOT_OBJ], + ¶mObj); + fprintf(stderr, "slotObj = %p, %s\n", paramPtr->slotObj, objectName(paramObj)); + if (result != TCL_OK) + return result; + + cmd = ObjectFindMethod(interp, paramObj, ObjStr(paramPtr->converterName), &pcl); + if (cmd == NULL) { + fprintf(stderr, "**** could not find checker method %s defined on %s\n", + ObjStr(paramPtr->converterName), objectName(paramObj)); + paramPtr->flags |= XOTCL_ARG_CURRENTLY_UNKNOWN; + /* TODO: for the time being, we do not return an error here */ + } } /* @@ -9625,6 +9633,13 @@ if (ArgumentCheck(interp, newValue, pPtr, &checkedData) != TCL_OK) { return TCL_ERROR; } + + if (pPtr->converter == convertViaCmd) { + fprintf(stderr, " ArgumentCheck of default %s -> %s\n",ObjStr(newValue),ObjStr((Tcl_Obj*)checkedData)); + pcPtr->objv[i] = (Tcl_Obj*)checkedData; + /* TODO: what happens with XOTCL_PC_MUST_DECR */ + } + } } else if (pPtr->flags & XOTCL_ARG_REQUIRED) { return XOTclVarErrMsg(interp, @@ -9688,11 +9703,12 @@ for (nppPtr = pPtr; nppPtr->name && *nppPtr->name == '-'; nppPtr ++) { if (strcmp(objStr, nppPtr->name) == 0) { + int j = nppPtr-paramPtr; /*fprintf(stderr, "... flag '%s' o=%d p=%d, objc=%d nrArgs %d\n", objStr, o, p, objc, nppPtr->nrArgs);*/ if (nppPtr->flags & XOTCL_ARG_REQUIRED) nrReq++; else nrOpt++; if (nppPtr->nrArgs == 0) { - pcPtr->clientData[nppPtr-paramPtr] = (ClientData)1; /* the flag was given */ - pcPtr->objv[nppPtr-paramPtr] = XOTclGlobalObjects[XOTE_ONE]; + pcPtr->clientData[j] = (ClientData)1; /* the flag was given */ + pcPtr->objv[j] = XOTclGlobalObjects[XOTE_ONE]; } else { /* we assume for now, nrArgs is at most 1 */ o++; p++; @@ -9704,10 +9720,17 @@ nppPtr->flags & XOTCL_ARG_REQUIRED ? "req":"not req", nppPtr->converter); #endif if (ArgumentCheck(interp, objv[p], nppPtr, - &pcPtr->clientData[nppPtr-paramPtr]) != TCL_OK) { + &pcPtr->clientData[j]) != TCL_OK) { return TCL_ERROR; } - pcPtr->objv[nppPtr-paramPtr] = objv[p]; + + if (nppPtr->converter == convertViaCmd) { + fprintf(stderr, " ArgumentCheck of %s -> %s\n",ObjStr(objv[p]),ObjStr((Tcl_Obj*)pcPtr->clientData[j])); + pcPtr->objv[j] = (Tcl_Obj*)pcPtr->clientData[j]; + } else { + pcPtr->objv[j] = objv[p]; + } + } else { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "Argument for parameter '", objStr, "' expected", (char *) NULL); @@ -9769,7 +9792,12 @@ fprintf(stderr, "... setting %s pPtr->objv[%d] to [%d]'%s' converter %p\n", pPtr->name, i, o, ObjStr(objv[o]), pPtr->converter); #endif - pcPtr->objv[i] = objv[o]; + if (pPtr->converter == convertViaCmd) { + fprintf(stderr, " ArgumentCheck of %s -> %s\n",ObjStr(objv[o]),ObjStr((Tcl_Obj*)pcPtr->clientData[i])); + pcPtr->objv[i] = (Tcl_Obj*)pcPtr->clientData[i]; + } else { + pcPtr->objv[i] = objv[o]; + } o++; i++; pPtr++; } } Index: generic/xotclInt.h =================================================================== diff -u -r5a0750dc422574bc5ae91d9b58c64b8f5713d405 -rcfee325944ac90fe94485cba109a7e99465073b5 --- generic/xotclInt.h (.../xotclInt.h) (revision 5a0750dc422574bc5ae91d9b58c64b8f5713d405) +++ generic/xotclInt.h (.../xotclInt.h) (revision cfee325944ac90fe94485cba109a7e99465073b5) @@ -412,6 +412,7 @@ Tcl_Obj *nameObj; Tcl_Obj *converterName; Tcl_Obj *paramObj; + Tcl_Obj *slotObj; } XOTclParam; typedef struct XOTclParamDefs { Index: tests/parameters.xotcl =================================================================== diff -u -r985438008a249cdf076309b9b3f0ba517a6f2db9 -rcfee325944ac90fe94485cba109a7e99465073b5 --- tests/parameters.xotcl (.../parameters.xotcl) (revision 985438008a249cdf076309b9b3f0ba517a6f2db9) +++ tests/parameters.xotcl (.../parameters.xotcl) (revision cfee325944ac90fe94485cba109a7e99465073b5) @@ -114,33 +114,28 @@ Test parameter count 10 Class create C -parameter {a {b:boolean} {c 1}} -C create c1 -? {C eval {:objectparameter}} "-object-mixin:relation -mixin:relation,arg=class-mixin\ --superclass:relation -object-filter:relation -filter:relation,arg=filter-mixin\ --class:relation -parameter:method,optional -noinit:method,optional,noarg\ --volatile:method,optional,noarg arg:initcmd,optional" +C create c1 + +? {C eval {:objectparameter}} \ +"-object-mixin:relation,slot=::xotcl2::Class::slot::object-mixin -mixin:relation,arg=class-mixin,slot=::xotcl2::Class::slot::mixin -superclass:relation,slot=::xotcl2::Class::slot::superclass -object-filter:relation,slot=::xotcl2::Class::slot::object-filter -filter:relation,arg=filter-mixin,slot=::xotcl2::Class::slot::filter -class:relation,slot=::xotcl2::Object::slot::class -parameter:method,optional -noinit:method,optional,noarg -volatile:method,optional,noarg arg:initcmd,optional" + ? {c1 eval {:objectparameter}} \ - "-a -b:boolean {-c 1} -mixin:relation,arg=object-mixin -filter:relation\ --class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\ -arg:initcmd,optional" +"-a:slot=::C::slot::a -b:boolean,slot=::C::slot::b {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::xotcl2::Object::slot::mixin -filter:relation,slot=::xotcl2::Object::slot::filter -class:relation,slot=::xotcl2::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg arg:initcmd,optional" ####################################################### # reclass to Object, no need to do anything on caching ####################################################### Test case reclass c1 class Object -? {c1 eval :objectparameter} "-mixin:relation,arg=object-mixin -filter:relation\ --class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\ -arg:initcmd,optional" +? {c1 eval :objectparameter} \ +"-mixin:relation,arg=object-mixin,slot=::xotcl2::Object::slot::mixin -filter:relation,slot=::xotcl2::Object::slot::filter -class:relation,slot=::xotcl2::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg arg:initcmd,optional" Class create D -superclass C -parameter {d:required} D create d1 -d 100 ? {d1 eval :objectparameter} \ - "-d:required -a -b:boolean {-c 1} -mixin:relation,arg=object-mixin -filter:relation\ --class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\ -arg:initcmd,optional" +"-d:required,slot=::D::slot::d -a:slot=::C::slot::a -b:boolean,slot=::C::slot::b {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::xotcl2::Object::slot::mixin -filter:relation,slot=::xotcl2::Object::slot::filter -class:relation,slot=::xotcl2::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg arg:initcmd,optional" ####################################################### # Add mixin @@ -150,38 +145,29 @@ Class create M2 -parameter {b2} D mixin M ? {d1 eval :objectparameter} \ - "-b -m1 -m2 -d:required -a {-c 1} -mixin:relation,arg=object-mixin -filter:relation\ --class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\ -arg:initcmd,optional" \ +"-b:slot=::M::slot::b -m1:slot=::M::slot::m1 -m2:slot=::M::slot::m2 -d:required,slot=::D::slot::d -a:slot=::C::slot::a {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::xotcl2::Object::slot::mixin -filter:relation,slot=::xotcl2::Object::slot::filter -class:relation,slot=::xotcl2::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg arg:initcmd,optional" \ "mixin added" M mixin M2 ? {d1 eval :objectparameter} \ - "-b2 -b -m1 -m2 -d:required -a {-c 1} -mixin:relation,arg=object-mixin -filter:relation\ --class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\ -arg:initcmd,optional" \ + "-b2:slot=::M2::slot::b2 -b:slot=::M::slot::b -m1:slot=::M::slot::m1 -m2:slot=::M::slot::m2 -d:required,slot=::D::slot::d -a:slot=::C::slot::a {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::xotcl2::Object::slot::mixin -filter:relation,slot=::xotcl2::Object::slot::filter -class:relation,slot=::xotcl2::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg arg:initcmd,optional" \ "transitive mixin added" D mixin "" #we should have again the old interface ? {d1 eval :objectparameter} \ - "-d:required -a -b:boolean {-c 1} -mixin:relation,arg=object-mixin -filter:relation\ --class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\ -arg:initcmd,optional" + "-d:required,slot=::D::slot::d -a:slot=::C::slot::a -b:boolean,slot=::C::slot::b {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::xotcl2::Object::slot::mixin -filter:relation,slot=::xotcl2::Object::slot::filter -class:relation,slot=::xotcl2::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg arg:initcmd,optional" +puts stderr ====1 C mixin M ? {d1 eval :objectparameter} \ - "-b2 -b -m1 -m2 -d:required -a {-c 1} -mixin:relation,arg=object-mixin -filter:relation\ --class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\ -arg:initcmd,optional" \ + "-b2:slot=::M2::slot::b2 -b:slot=::M::slot::b -m1:slot=::M::slot::m1 -m2:slot=::M::slot::m2 -d:required,slot=::D::slot::d -a:slot=::C::slot::a {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::xotcl2::Object::slot::mixin -filter:relation,slot=::xotcl2::Object::slot::filter -class:relation,slot=::xotcl2::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg arg:initcmd,optional" \ "mixin added" C mixin "" #we should have again the old interface ? {d1 eval :objectparameter} \ - "-d:required -a -b:boolean {-c 1} -mixin:relation,arg=object-mixin -filter:relation\ --class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\ -arg:initcmd,optional" + "-d:required,slot=::D::slot::d -a:slot=::C::slot::a -b:boolean,slot=::C::slot::b {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::xotcl2::Object::slot::mixin -filter:relation,slot=::xotcl2::Object::slot::filter -class:relation,slot=::xotcl2::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg arg:initcmd,optional" ####################################################### @@ -530,20 +516,23 @@ # are already predefined, define the rest. # TODO: should go finally to predefined. -::xotcl::methodParameterSlot method type=mixin {name value arg} { +::xotcl::Slot method type=mixin {name value arg} { if {![::xotcl::is $value mixin $arg]} { error "Value '$value' of $name has not mixin $arg" } + return $value } -::xotcl::methodParameterSlot method type=baseclass {name value} { +::xotcl::Slot method type=baseclass {name value} { if {![::xotcl::is $value baseclass]} { error "Value '$value' of $name is not a baseclass" } + return $value } -::xotcl::methodParameterSlot method type=metaclass {name value} { +::xotcl::Slot method type=metaclass {name value} { if {![::xotcl::is $value metaclass]} { error "Value '$value' of $name is not a metaclass" } + return $value } D method foo-base {x:baseclass} {return $x} @@ -677,15 +666,15 @@ } #puts stderr =====2 -? {parameterFromSlot ParamTest o} "o:object" -? {parameterFromSlot ParamTest c} "c:class" -? {parameterFromSlot ParamTest c1} "c1:class,type=::MC" -? {parameterFromSlot ParamTest d} "d:object,type=::C" -? {parameterFromSlot ParamTest d1} "d1:object,type=::C" -? {parameterFromSlot ParamTest mix} "mix:mixin,arg=M" -? {parameterFromSlot ParamTest x} "x:object,multivalued o" -? {parameterFromSlot ParamTest u} "u:upper" -? {parameterFromSlot ParamTest us} "us:upper,multivalued" +? {parameterFromSlot ParamTest o} "o:object,slot=::ParamTest::slot::o" +? {parameterFromSlot ParamTest c} "c:class,slot=::ParamTest::slot::c" +? {parameterFromSlot ParamTest c1} "c1:class,type=::MC,slot=::ParamTest::slot::c1" +? {parameterFromSlot ParamTest d} "d:object,type=::C,slot=::ParamTest::slot::d" +? {parameterFromSlot ParamTest d1} "d1:object,type=::C,slot=::ParamTest::slot::d1" +? {parameterFromSlot ParamTest mix} "mix:mixin,arg=M,slot=::ParamTest::slot::mix" +? {parameterFromSlot ParamTest x} "x:object,multivalued,slot=::ParamTest::slot::x o" +? {parameterFromSlot ParamTest u} "u:upper,slot=::ParamTest::slot::u" +? {parameterFromSlot ParamTest us} "us:upper,multivalued,slot=::ParamTest::slot::us" #puts stderr =====3 ? {ParamTest create p -o o} ::p Index: tests/slottest.xotcl =================================================================== diff -u -rf4e75c452cf99c87ad8705c954cb9548652873fa -rcfee325944ac90fe94485cba109a7e99465073b5 --- tests/slottest.xotcl (.../slottest.xotcl) (revision f4e75c452cf99c87ad8705c954cb9548652873fa) +++ tests/slottest.xotcl (.../slottest.xotcl) (revision cfee325944ac90fe94485cba109a7e99465073b5) @@ -402,21 +402,33 @@ #? {catch {p2 append salary b}} 1 ? {p2 salary} 1009 - +puts stderr =====1 Person slots { - Attribute create sex -type "my sex" { - :method sex {value} { + Attribute create sex -type "sex" { + :method type=sex {name value} { + puts stderr "[self] slot specific converter" switch -glob $value { - m* {my uplevel {$obj set $var m}; return 1} - f* {my uplevel {$obj set $var f}; return 1} - default {return 0} + m* {return m} + f* {return f} + default {error "expected sex but got $value"} } } } } +puts stderr =====2 Person p3 -sex male +puts stderr =====3 ? {p3 sex} m +puts stderr =====4 +Person method foo {s:sex,slot=::Person::slot::sex} {puts s=$s; return $s} +puts stderr =====5 +? {p3 foo male} "m" +puts stderr =====6 +? {p3 sex male} m +puts stderr =====5 +puts stderr =====6 + set ::hu 0 Class C -slots { Attribute x -initcmd {incr ::hu; set x 101}