Index: generic/gentclAPI.decls =================================================================== diff -u -r29267f0c9db8387f58b03ffc124fc138ad88e463 -rbc6eb608936be7ce3ab17f64981902a4f51194d1 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision 29267f0c9db8387f58b03ffc124fc138ad88e463) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision bc6eb608936be7ce3ab17f64981902a4f51194d1) @@ -82,11 +82,6 @@ {-argName "args" -type allargs} } xotclCmd is XOTclIsCmd { - {-argName "object" -required 1 -type tclobj} - {-argName "objectkind" -type "type|object|class|baseclass|metaclass|hasmixin"} - {-argName "value" -required 0 -type tclobj} -} -xotclCmd is2 XOTclIs2Cmd { {-argName "value" -required 1 -type tclobj} {-argName "constraint" -required 1 -type tclobj} {-argName "-hasmixin" -required 0 -nrargs 1 -type tclobj} @@ -124,6 +119,11 @@ {-argName "fromNs" -required 1 -type tclobj} {-argName "toNs" -required 1 -type tclobj} } +xotclCmd objectproperty XOTclObjectpropertyCmd { + {-argName "object" -required 1 -type tclobj} + {-argName "objectkind" -type "type|object|class|baseclass|metaclass|hasmixin"} + {-argName "value" -required 0 -type tclobj} +} xotclCmd __qualify XOTclQualifyObjCmd { {-argName "name" -required 1 -type tclobj} } Index: generic/predefined.h =================================================================== diff -u -r29267f0c9db8387f58b03ffc124fc138ad88e463 -rbc6eb608936be7ce3ab17f64981902a4f51194d1 --- generic/predefined.h (.../predefined.h) (revision 29267f0c9db8387f58b03ffc124fc138ad88e463) +++ generic/predefined.h (.../predefined.h) (revision bc6eb608936be7ce3ab17f64981902a4f51194d1) @@ -432,15 +432,15 @@ "::xotcl::setinstvar [::xotcl::self]::slot __parameter $arglist}\n" "proc createBootstrapAttributeSlots {} {}\n" "::xotcl::Slot method type=hasmixin {name value arg} {\n" -"if {![::xotcl::is $value hasmixin $arg]} {\n" +"if {![::xotcl::objectproperty $value hasmixin $arg]} {\n" "error \"expected object with mixin $arg but got \\\"$value\\\" for parameter $name\"}\n" "return $value}\n" "::xotcl::Slot method type=baseclass {name value} {\n" -"if {![::xotcl::is $value baseclass]} {\n" +"if {![::xotcl::objectproperty $value baseclass]} {\n" "error \"expected baseclass but got \\\"$value\\\" for parameter $name\"}\n" "return $value}\n" "::xotcl::Slot method type=metaclass {name value} {\n" -"if {![::xotcl::is $value metaclass]} {\n" +"if {![::xotcl::objectproperty $value metaclass]} {\n" "error \"expected metaclass but got \\\"$value\\\" for parameter $name\"}\n" "return $value}}\n" "::xotcl2::Class create ::xotcl::ScopedNew -superclass ::xotcl2::Class {\n" Index: generic/predefined.xotcl =================================================================== diff -u -r29267f0c9db8387f58b03ffc124fc138ad88e463 -rbc6eb608936be7ce3ab17f64981902a4f51194d1 --- generic/predefined.xotcl (.../predefined.xotcl) (revision 29267f0c9db8387f58b03ffc124fc138ad88e463) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision bc6eb608936be7ce3ab17f64981902a4f51194d1) @@ -832,21 +832,21 @@ ################################################################## ::xotcl::Slot method type=hasmixin {name value arg} { - if {![::xotcl::is $value hasmixin $arg]} { + if {![::xotcl::objectproperty $value hasmixin $arg]} { error "expected object with mixin $arg but got \"$value\" for parameter $name" } return $value } ::xotcl::Slot method type=baseclass {name value} { - if {![::xotcl::is $value baseclass]} { + if {![::xotcl::objectproperty $value baseclass]} { error "expected baseclass but got \"$value\" for parameter $name" } return $value } ::xotcl::Slot method type=metaclass {name value} { - if {![::xotcl::is $value metaclass]} { + if {![::xotcl::objectproperty $value metaclass]} { error "expected metaclass but got \"$value\" for parameter $name" } return $value Index: generic/tclAPI.h =================================================================== diff -u -r29267f0c9db8387f58b03ffc124fc138ad88e463 -rbc6eb608936be7ce3ab17f64981902a4f51194d1 --- generic/tclAPI.h (.../tclAPI.h) (revision 29267f0c9db8387f58b03ffc124fc138ad88e463) +++ generic/tclAPI.h (.../tclAPI.h) (revision bc6eb608936be7ce3ab17f64981902a4f51194d1) @@ -76,27 +76,27 @@ } enum SelfoptionIdx {SelfoptionNULL, SelfoptionProcIdx, SelfoptionClassIdx, SelfoptionActivelevelIdx, SelfoptionArgsIdx, SelfoptionActivemixinIdx, SelfoptionCalledprocIdx, SelfoptionCalledmethodIdx, SelfoptionCalledclassIdx, SelfoptionCallingprocIdx, SelfoptionCallingclassIdx, SelfoptionCallinglevelIdx, SelfoptionCallingobjectIdx, SelfoptionFilterregIdx, SelfoptionIsnextcallIdx, SelfoptionNextIdx}; -static int convertToObjectkind(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, +static int convertToMethodproperty(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr) { int index, result; - static CONST char *opts[] = {"type", "object", "class", "baseclass", "metaclass", "hasmixin", NULL}; - result = Tcl_GetIndexFromObj(interp, objPtr, opts, "objectkind", 0, &index); + static CONST char *opts[] = {"protected", "redefine-protected", "slotobj", NULL}; + result = Tcl_GetIndexFromObj(interp, objPtr, opts, "methodproperty", 0, &index); *clientData = (ClientData) INT2PTR(index + 1); *outObjPtr = objPtr; return result; } -enum ObjectkindIdx {ObjectkindNULL, ObjectkindTypeIdx, ObjectkindObjectIdx, ObjectkindClassIdx, ObjectkindBaseclassIdx, ObjectkindMetaclassIdx, ObjectkindHasmixinIdx}; +enum MethodpropertyIdx {MethodpropertyNULL, MethodpropertyProtectedIdx, MethodpropertyRedefine_protectedIdx, MethodpropertySlotobjIdx}; -static int convertToMethodproperty(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, +static int convertToObjectkind(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr) { int index, result; - static CONST char *opts[] = {"protected", "redefine-protected", "slotobj", NULL}; - result = Tcl_GetIndexFromObj(interp, objPtr, opts, "methodproperty", 0, &index); + static CONST char *opts[] = {"type", "object", "class", "baseclass", "metaclass", "hasmixin", NULL}; + result = Tcl_GetIndexFromObj(interp, objPtr, opts, "objectkind", 0, &index); *clientData = (ClientData) INT2PTR(index + 1); *outObjPtr = objPtr; return result; } -enum MethodpropertyIdx {MethodpropertyNULL, MethodpropertyProtectedIdx, MethodpropertyRedefine_protectedIdx, MethodpropertySlotobjIdx}; +enum ObjectkindIdx {ObjectkindNULL, ObjectkindTypeIdx, ObjectkindObjectIdx, ObjectkindClassIdx, ObjectkindBaseclassIdx, ObjectkindMetaclassIdx, ObjectkindHasmixinIdx}; static int convertToRelationtype(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr) { @@ -202,13 +202,13 @@ static int XOTclGetSelfObjCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclImportvarCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclInterpObjCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclIs2CmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclIsCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclMethodCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclMethodPropertyCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclMyCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclNSCopyCmdsStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclNSCopyVarsStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclObjectpropertyCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclQualifyObjCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclRelationCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclSetInstvarCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -283,13 +283,13 @@ static int XOTclGetSelfObjCmd(Tcl_Interp *interp, int selfoption); static int XOTclImportvarCmd(Tcl_Interp *interp, XOTclObject *object, int nobjc, Tcl_Obj *CONST nobjv[]); static int XOTclInterpObjCmd(Tcl_Interp *interp, char *name, int objc, Tcl_Obj *CONST objv[]); -static int XOTclIs2Cmd(Tcl_Interp *interp, Tcl_Obj *value, Tcl_Obj *constraint, Tcl_Obj *withHasmixin, Tcl_Obj *withType, Tcl_Obj *arg); -static int XOTclIsCmd(Tcl_Interp *interp, Tcl_Obj *object, int objectkind, Tcl_Obj *value); +static int XOTclIsCmd(Tcl_Interp *interp, Tcl_Obj *value, Tcl_Obj *constraint, Tcl_Obj *withHasmixin, Tcl_Obj *withType, Tcl_Obj *arg); static int XOTclMethodCmd(Tcl_Interp *interp, XOTclObject *object, int withInner_namespace, int withPer_object, int withPublic, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition); static int XOTclMethodPropertyCmd(Tcl_Interp *interp, XOTclObject *object, int withPer_object, Tcl_Obj *methodName, int methodproperty, Tcl_Obj *value); static int XOTclMyCmd(Tcl_Interp *interp, int withLocal, Tcl_Obj *method, int nobjc, Tcl_Obj *CONST nobjv[]); static int XOTclNSCopyCmds(Tcl_Interp *interp, Tcl_Obj *fromNs, Tcl_Obj *toNs); static int XOTclNSCopyVars(Tcl_Interp *interp, Tcl_Obj *fromNs, Tcl_Obj *toNs); +static int XOTclObjectpropertyCmd(Tcl_Interp *interp, Tcl_Obj *object, int objectkind, Tcl_Obj *value); static int XOTclQualifyObjCmd(Tcl_Interp *interp, Tcl_Obj *name); static int XOTclRelationCmd(Tcl_Interp *interp, XOTclObject *object, int relationtype, Tcl_Obj *value); static int XOTclSetInstvarCmd(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *variable, Tcl_Obj *value); @@ -365,13 +365,13 @@ XOTclGetSelfObjCmdIdx, XOTclImportvarCmdIdx, XOTclInterpObjCmdIdx, - XOTclIs2CmdIdx, XOTclIsCmdIdx, XOTclMethodCmdIdx, XOTclMethodPropertyCmdIdx, XOTclMyCmdIdx, XOTclNSCopyCmdsIdx, XOTclNSCopyVarsIdx, + XOTclObjectpropertyCmdIdx, XOTclQualifyObjCmdIdx, XOTclRelationCmdIdx, XOTclSetInstvarCmdIdx, @@ -1712,12 +1712,12 @@ } static int -XOTclIs2CmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { +XOTclIsCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; if (ArgumentParse(interp, objc, objv, NULL, objv[0], - method_definitions[XOTclIs2CmdIdx].paramDefs, - method_definitions[XOTclIs2CmdIdx].nrParameters, + method_definitions[XOTclIsCmdIdx].paramDefs, + method_definitions[XOTclIsCmdIdx].nrParameters, &pc) != TCL_OK) { return TCL_ERROR; } else { @@ -1728,32 +1728,12 @@ Tcl_Obj *arg = (Tcl_Obj *)pc.clientData[4]; parseContextRelease(&pc); - return XOTclIs2Cmd(interp, value, constraint, withHasmixin, withType, arg); + return XOTclIsCmd(interp, value, constraint, withHasmixin, withType, arg); } } static int -XOTclIsCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - - if (ArgumentParse(interp, objc, objv, NULL, objv[0], - method_definitions[XOTclIsCmdIdx].paramDefs, - method_definitions[XOTclIsCmdIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - Tcl_Obj *object = (Tcl_Obj *)pc.clientData[0]; - int objectkind = (int )PTR2INT(pc.clientData[1]); - Tcl_Obj *value = (Tcl_Obj *)pc.clientData[2]; - - parseContextRelease(&pc); - return XOTclIsCmd(interp, object, objectkind, value); - - } -} - -static int XOTclMethodCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -1859,6 +1839,26 @@ } static int +XOTclObjectpropertyCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + + if (ArgumentParse(interp, objc, objv, NULL, objv[0], + method_definitions[XOTclObjectpropertyCmdIdx].paramDefs, + method_definitions[XOTclObjectpropertyCmdIdx].nrParameters, + &pc) != TCL_OK) { + return TCL_ERROR; + } else { + Tcl_Obj *object = (Tcl_Obj *)pc.clientData[0]; + int objectkind = (int )PTR2INT(pc.clientData[1]); + Tcl_Obj *value = (Tcl_Obj *)pc.clientData[2]; + + parseContextRelease(&pc); + return XOTclObjectpropertyCmd(interp, object, objectkind, value); + + } +} + +static int XOTclQualifyObjCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -2252,18 +2252,13 @@ {"name", 0, 0, convertToString}, {"args", 0, 0, convertToNothing}} }, -{"::xotcl::is2", XOTclIs2CmdStub, 5, { +{"::xotcl::is", XOTclIsCmdStub, 5, { {"value", 1, 0, convertToTclobj}, {"constraint", 1, 0, convertToTclobj}, {"-hasmixin", 0, 1, convertToTclobj}, {"-type", 0, 1, convertToTclobj}, {"arg", 0, 0, convertToTclobj}} }, -{"::xotcl::is", XOTclIsCmdStub, 3, { - {"object", 1, 0, convertToTclobj}, - {"objectkind", 0, 0, convertToObjectkind}, - {"value", 0, 0, convertToTclobj}} -}, {"::xotcl::method", XOTclMethodCmdStub, 9, { {"object", 1, 0, convertToObject}, {"-inner-namespace", 0, 0, convertToString}, @@ -2295,6 +2290,11 @@ {"fromNs", 1, 0, convertToTclobj}, {"toNs", 1, 0, convertToTclobj}} }, +{"::xotcl::objectproperty", XOTclObjectpropertyCmdStub, 3, { + {"object", 1, 0, convertToTclobj}, + {"objectkind", 0, 0, convertToObjectkind}, + {"value", 0, 0, convertToTclobj}} +}, {"::xotcl::__qualify", XOTclQualifyObjCmdStub, 1, { {"name", 1, 0, convertToTclobj}} }, Index: generic/xotcl.c =================================================================== diff -u -r29267f0c9db8387f58b03ffc124fc138ad88e463 -rbc6eb608936be7ce3ab17f64981902a4f51194d1 --- generic/xotcl.c (.../xotcl.c) (revision 29267f0c9db8387f58b03ffc124fc138ad88e463) +++ generic/xotcl.c (.../xotcl.c) (revision bc6eb608936be7ce3ab17f64981902a4f51194d1) @@ -6312,18 +6312,18 @@ ov[2] = pPtr->nameObj; ov[3] = objPtr; - /*fprintf(stderr, "call converter %s on %s \n", ObjStr(pPtr->converterName), ObjStr(ov[0]));*/ + /*fprintf(stderr, "convertViaCmd call converter %s (refCount %d) on %s paramPtr %p\n", + ObjStr(pPtr->converterName), pPtr->converterName->refCount, ObjStr(ov[0]), pPtr);*/ oc = 4; if (pPtr->converterArg) { ov[4] = pPtr->converterArg; oc++; } result = Tcl_EvalObjv(interp, oc, ov, 0); - if (result == TCL_OK) { - /*fprintf(stderr, "convertViaCmd converts %s to '%s'\n", - ObjStr(objPtr), ObjStr(Tcl_GetObjResult(interp)));*/ + /*fprintf(stderr, "convertViaCmd converts %s to '%s' paramPtr %p\n", + ObjStr(objPtr), ObjStr(Tcl_GetObjResult(interp)),pPtr);*/ *outObjPtr = Tcl_GetObjResult(interp); *clientData = (ClientData) *outObjPtr; @@ -11414,61 +11414,66 @@ return TCL_OK; } + /* xotclCmd is XOTclIsCmd { - {-argName "object" -required 1 -type tclobj} - {-argName "objectkind" -type "type|object|class|baseclass|metaclass|hasmixin"} - {-argName "value" -required 0 -type tclobj} + {-argName "value" -required 1 -type tclobj} + {-argName "constraint" -required 1 -type tclobj} + {-argName "-hasmixin" -required 0 -nrargs 1 -type tclobj} + {-argName "-type" -required 0 -nrargs 1 -type tclobj} + {-argName "arg" -required 0 -type tclobj} } */ -static int XOTclIsCmd(Tcl_Interp *interp, Tcl_Obj *obj, int objectkind, Tcl_Obj *value) { - int success = TCL_ERROR; +static int XOTclIsCmd(Tcl_Interp *interp, Tcl_Obj *value, Tcl_Obj *constraintObj, + Tcl_Obj *withHasmixin, Tcl_Obj *withType, Tcl_Obj *arg) { + int result = TCL_OK, success; + char *constraintString = ObjStr(constraintObj); XOTclObject *object; - XOTclClass *cl; + XOTclClass *typeClass, *mixinClass; - switch (objectkind) { - case ObjectkindTypeIdx: - if (value == NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " type "); - success = (GetObjectFromObj(interp, obj, &object) == TCL_OK) - && (GetClassFromObj(interp, value, &cl, 0) == TCL_OK) - && isSubType(object->cl, cl); - break; + if (isTypeString(constraintString)) { + if (arg== NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, "type "); + success = (GetObjectFromObj(interp, value, &object) == TCL_OK) + && (GetClassFromObj(interp, arg, &typeClass, 0) == TCL_OK) + && isSubType(object->cl, typeClass); - case ObjectkindObjectIdx: - if (value != NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " object"); - success = (GetObjectFromObj(interp, obj, &object) == TCL_OK); - break; + Tcl_SetIntObj(Tcl_GetObjResult(interp), success); - case ObjectkindClassIdx: - if (value != NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " class"); - success = (GetObjectFromObj(interp, obj, &object) == TCL_OK) && XOTclObjectIsClass(object); - break; + } else if (withHasmixin || withType) { + if ((!isObjectString(constraintString) && !isClassString(constraintString)) || arg != NULL) { + return XOTclObjErrArgCnt(interp, NULL, NULL, "object|class ?-hasmixin cl? ?-type cl?"); + } + if (*constraintString == 'o') { + success = (GetObjectFromObj(interp, value, &object) == TCL_OK); + } else { + success = (GetClassFromObj(interp, value, (XOTclClass **)&object, 0) == TCL_OK); + } + if (success && withType) { + success = (GetClassFromObj(interp, withType, &typeClass, 0) == TCL_OK) + && isSubType(object->cl, typeClass); + } + if (success && withHasmixin) { + success = (GetClassFromObj(interp, withHasmixin, &mixinClass, 0) == TCL_OK) + && hasMixin(interp, object, mixinClass); + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), success); - case ObjectkindMetaclassIdx: - if (value != NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " metaclass"); - success = (GetObjectFromObj(interp, obj, &object) == TCL_OK) - && XOTclObjectIsClass(object) - && IsMetaClass(interp, (XOTclClass*)object, 1); - break; + } else if (arg != NULL) { + Tcl_Obj *paramObj = Tcl_DuplicateObj(value); - case ObjectkindBaseclassIdx: - if (value != NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " baseclass"); - success = (GetObjectFromObj(interp, obj, &object) == TCL_OK) - && XOTclObjectIsClass(object) - && IsBaseClass((XOTclClass*)object); - break; - - case ObjectkindHasmixinIdx: - if (value == NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " hasmixin "); - success = (GetObjectFromObj(interp, obj, &object) == TCL_OK) - && (GetClassFromObj(interp, value, &cl, 0) == TCL_OK) - && hasMixin(interp, object, cl); - break; + INCR_REF_COUNT(paramObj); + Tcl_AppendToObj(paramObj, ",arg=", 5); + Tcl_AppendObjToObj(paramObj, arg); + + result = XOTclValuecheckCmd(interp, 1, paramObj, value); + DECR_REF_COUNT(paramObj); + } else { + INCR_REF_COUNT(constraintObj); + result = XOTclValuecheckCmd(interp, 1, constraintObj, value); + DECR_REF_COUNT(constraintObj); } - - Tcl_SetIntObj(Tcl_GetObjResult(interp), success); - return TCL_OK; + return result; } /* @@ -11943,6 +11948,65 @@ } /* +xotclCmd objectproperty XOTclObjectpropertyCmd { + {-argName "object" -required 1 -type tclobj} + {-argName "objectkind" -type "type|object|class|baseclass|metaclass|hasmixin"} + {-argName "value" -required 0 -type tclobj} +} +*/ +static int XOTclObjectpropertyCmd(Tcl_Interp *interp, Tcl_Obj *obj, int objectkind, Tcl_Obj *value) { + int success = TCL_ERROR; + XOTclObject *object; + XOTclClass *cl; + + /* fprintf(stderr, "XOTclObjectpropertyCmd\n");*/ + + switch (objectkind) { + case ObjectkindTypeIdx: + if (value == NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " type "); + success = (GetObjectFromObj(interp, obj, &object) == TCL_OK) + && (GetClassFromObj(interp, value, &cl, 0) == TCL_OK) + && isSubType(object->cl, cl); + break; + + case ObjectkindObjectIdx: + if (value != NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " object"); + success = (GetObjectFromObj(interp, obj, &object) == TCL_OK); + break; + + case ObjectkindClassIdx: + if (value != NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " class"); + success = (GetObjectFromObj(interp, obj, &object) == TCL_OK) && XOTclObjectIsClass(object); + break; + + case ObjectkindMetaclassIdx: + if (value != NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " metaclass"); + success = (GetObjectFromObj(interp, obj, &object) == TCL_OK) + && XOTclObjectIsClass(object) + && IsMetaClass(interp, (XOTclClass*)object, 1); + break; + + case ObjectkindBaseclassIdx: + if (value != NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " baseclass"); + success = (GetObjectFromObj(interp, obj, &object) == TCL_OK) + && XOTclObjectIsClass(object) + && IsBaseClass((XOTclClass*)object); + break; + + case ObjectkindHasmixinIdx: + if (value == NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " hasmixin "); + success = (GetObjectFromObj(interp, obj, &object) == TCL_OK) + && (GetClassFromObj(interp, value, &cl, 0) == TCL_OK) + && hasMixin(interp, object, cl); + break; + } + + + Tcl_SetIntObj(Tcl_GetObjResult(interp), success); + return TCL_OK; +} + +/* xotclCmd __qualify XOTclQualifyObjCmd { {-argName "name" -required 1 -type tclobj} } @@ -12412,13 +12476,32 @@ return result; } -static void ParamFreeInternalRep(register Tcl_Obj *objPtr); +typedef struct XOTclParamWrapper { + XOTclParam *paramPtr; + int refCount; + int canFree; +} XOTclParamWrapper; + +static Tcl_DupInternalRepProc ParamDupInteralRep; +static Tcl_FreeInternalRepProc ParamFreeInternalRep; +static Tcl_UpdateStringProc ParamUpdateString; + +static void ParamUpdateString(Tcl_Obj *objPtr) { + Tcl_Panic("%s of type %s should not be called", "updateStringProc", + objPtr->typePtr->name); +} + +static void ParamDupInteralRep(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { + Tcl_Panic("%s of type %s should not be called", "dupStringProc", + srcPtr->typePtr->name); +} + static int ParamSetFromAny(Tcl_Interp *interp, register Tcl_Obj *objPtr); static Tcl_ObjType paramObjType = { - "xotclParam", /* name */ + "xotclParam", /* name */ ParamFreeInternalRep, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ + ParamDupInteralRep, /* dupIntRepProc */ + ParamUpdateString, /* updateStringProc */ ParamSetFromAny /* setFromAnyProc */ }; @@ -12427,10 +12510,19 @@ register Tcl_Obj *objPtr) /* Param structure object with internal * representation to free. */ { - XOTclParam *paramPtr = (XOTclParam *) objPtr->internalRep.twoPtrValue.ptr1; - if (paramPtr != NULL) { - /*fprintf(stderr, "freeing %p\n",paramPtr);*/ - ParamsFree(paramPtr); + XOTclParamWrapper *paramWrapperPtr = (XOTclParamWrapper *)objPtr->internalRep.twoPtrValue.ptr1; + + if (paramWrapperPtr != NULL) { + /* fprintf(stderr, "ParamFreeInternalRep freeing wrapper %p paramPtr %p refCount %dcanFree %d\n", + paramWrapperPtr, paramWrapperPtr->paramPtr, paramWrapperPtr->refCount, + paramWrapperPtr->canFree);*/ + + if (paramWrapperPtr->canFree) { + ParamsFree(paramWrapperPtr->paramPtr); + FREE(XOTclParamWrapper, paramWrapperPtr); + } else { + paramWrapperPtr->refCount--; + } } } @@ -12439,26 +12531,30 @@ Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr) /* The object to convert. */ { - XOTclParam *paramPtr; + XOTclParamWrapper *paramWrapperPtr = NEW(XOTclParamWrapper); Tcl_Obj *fullParamObj = Tcl_NewStringObj("value:", 6); int result, possibleUnknowns = 0, plainParams = 0; - paramPtr = ParamsNew(1); - /*fprintf(stderr, "allocating %p\n",paramPtr);*/ + paramWrapperPtr->paramPtr = ParamsNew(1); + paramWrapperPtr->refCount = 1; + paramWrapperPtr->canFree = 0; + /*fprintf(stderr, "allocating %p\n",paramWrapperPtr->paramPtr);*/ Tcl_AppendToObj(fullParamObj, ObjStr(objPtr), -1); INCR_REF_COUNT(fullParamObj); result = ParamParse(interp, "valuecheck", fullParamObj, XOTCL_DISALLOWED_ARG_VALUEECHECK /* disallowed options */, - paramPtr, &possibleUnknowns, &plainParams); + paramWrapperPtr->paramPtr, &possibleUnknowns, &plainParams); /* Here, we want to treat currently unknown user level converters as error. */ - if (paramPtr->flags & XOTCL_ARG_CURRENTLY_UNKNOWN) { + if (paramWrapperPtr->paramPtr->flags & XOTCL_ARG_CURRENTLY_UNKNOWN) { + ParamsFree(paramWrapperPtr->paramPtr); + FREE(XOTclParamWrapper, paramWrapperPtr); result = TCL_ERROR; } else if (result == TCL_OK) { TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (void *)paramPtr; + objPtr->internalRep.twoPtrValue.ptr1 = (void *)paramWrapperPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = ¶mObjType; } @@ -12475,24 +12571,27 @@ } */ static int XOTclValuecheckCmd(Tcl_Interp *interp, int withNocomplain, Tcl_Obj *objPtr, Tcl_Obj *value) { - ClientData checkedData; + XOTclParamWrapper *paramWrapperPtr; XOTclParam *paramPtr; + ClientData checkedData; Tcl_Obj *outObjPtr; int result, flags = 0; + /*fprintf(stderr, "XOTclValuecheckCmd %s %s\n",ObjStr(objPtr), ObjStr(value));*/ + if (objPtr->typePtr == ¶mObjType) { - paramPtr = (XOTclParam *) objPtr->internalRep.twoPtrValue.ptr1; + paramWrapperPtr = (XOTclParamWrapper *) objPtr->internalRep.twoPtrValue.ptr1; } else { result = ParamSetFromAny(interp, objPtr); if (result == TCL_OK) { - paramPtr = (XOTclParam *) objPtr->internalRep.twoPtrValue.ptr1; + paramWrapperPtr = (XOTclParamWrapper *) objPtr->internalRep.twoPtrValue.ptr1; } else { return XOTclVarErrMsg(interp, "invalid value constraints \"", ObjStr(objPtr), "\"", (char *) NULL); } } - + paramPtr = paramWrapperPtr->paramPtr; result = ArgumentCheck(interp, value, paramPtr, &flags, &checkedData, &outObjPtr); if (paramPtr->converter == convertViaCmd && @@ -12512,73 +12611,19 @@ Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); } - return result; -} - - -/* -xotclCmd is2 XOTclIs2Cmd { - {-argName "value" -required 1 -type tclobj} - {-argName "constraint" -required 1 -type tclobj} - {-argName "-hasmixin" -required 0 -nrargs 1 -type tclobj} - {-argName "-type" -required 0 -nrargs 1 -type tclobj} - {-argName "arg" -required 0 -type tclobj} -} -*/ -static int XOTclIs2Cmd(Tcl_Interp *interp, Tcl_Obj *value, Tcl_Obj *constraintObj, - Tcl_Obj *withHasmixin, Tcl_Obj *withType, Tcl_Obj *arg) { - int result = TCL_OK, success; - char *constraintString = ObjStr(constraintObj); - XOTclObject *object; - XOTclClass *typeClass, *mixinClass; - - if (isTypeString(constraintString)) { - if (arg== NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, "type "); - success = (GetObjectFromObj(interp, value, &object) == TCL_OK) - && (GetClassFromObj(interp, arg, &typeClass, 0) == TCL_OK) - && isSubType(object->cl, typeClass); - - Tcl_SetIntObj(Tcl_GetObjResult(interp), success); - - } else if (withHasmixin || withType) { - if ((!isObjectString(constraintString) && !isClassString(constraintString)) || arg != NULL) { - return XOTclObjErrArgCnt(interp, NULL, NULL, "object|class ?-hasmixin cl? ?-type cl?"); - } - if (*constraintString == 'o') { - success = (GetObjectFromObj(interp, value, &object) == TCL_OK); - } else { - success = (GetClassFromObj(interp, value, (XOTclClass **)&object, 0) == TCL_OK); - } - if (success && withType) { - success = (GetClassFromObj(interp, withType, &typeClass, 0) == TCL_OK) - && isSubType(object->cl, typeClass); - } - if (success && withHasmixin) { - success = (GetClassFromObj(interp, withHasmixin, &mixinClass, 0) == TCL_OK) - && hasMixin(interp, object, mixinClass); - } - Tcl_SetIntObj(Tcl_GetObjResult(interp), success); - - } else if (arg != NULL) { - Tcl_Obj *paramObj = Tcl_DuplicateObj(value); - - INCR_REF_COUNT(paramObj); - Tcl_AppendToObj(paramObj, ",arg=", 5); - Tcl_AppendObjToObj(paramObj, arg); - - result = XOTclValuecheckCmd(interp, 1, paramObj, value); - DECR_REF_COUNT(paramObj); + /*fprintf(stderr, "XOTclValuecheckCmd paramPtr %p final refcount of wrapper %d can free %d\n",paramPtr, + paramWrapperPtr->refCount, paramWrapperPtr->canFree);*/ + if (paramWrapperPtr->refCount == 0) { + /* fprintf(stderr, "XOTclValuecheckCmd paramPtr %p manual free\n",paramPtr);*/ + ParamsFree(paramWrapperPtr->paramPtr); + FREE(XOTclParamWrapper, paramWrapperPtr); } else { - result = XOTclValuecheckCmd(interp, 1, constraintObj, value); + paramWrapperPtr->canFree = 1; } return result; } - - - - /*************************** * End generated XOTcl commands ***************************/ Index: library/lib/xotcl1.xotcl =================================================================== diff -u -r29267f0c9db8387f58b03ffc124fc138ad88e463 -rbc6eb608936be7ce3ab17f64981902a4f51194d1 --- library/lib/xotcl1.xotcl (.../xotcl1.xotcl) (revision 29267f0c9db8387f58b03ffc124fc138ad88e463) +++ library/lib/xotcl1.xotcl (.../xotcl1.xotcl) (revision bc6eb608936be7ce3ab17f64981902a4f51194d1) @@ -386,7 +386,7 @@ Object instproc isobject {{object:substdefault "[self]"}} {::xotcl::is $object object} Object instproc isclass {{class:substdefault "[self]"}} {::xotcl::is $class class} Object instproc ismetaclass {{class:substdefault "[self]"}} {::xotcl::is $class metaclass} - Object instproc ismixin {class} {::xotcl::is [self] hasmixin $class} + Object instproc ismixin {class} {::xotcl::is [self] object -hasmixin $class} Object instproc istype {class} {::xotcl::is [self] type $class} ::xotcl::alias Object contains ::xotcl::classes::xotcl2::Object::contains @@ -481,7 +481,7 @@ # support for XOTcl 1.* specific convenience routines Object instproc hasclass cl { - if {[::xotcl::is [self] hasmixin $cl]} {return 1} + if {[::xotcl::is [self] object -hasmixin $cl]} {return 1} ::xotcl::is [self] type $cl } Object instproc filtersearch {filter} { Index: tests/parameters.xotcl =================================================================== diff -u -r29267f0c9db8387f58b03ffc124fc138ad88e463 -rbc6eb608936be7ce3ab17f64981902a4f51194d1 --- tests/parameters.xotcl (.../parameters.xotcl) (revision 29267f0c9db8387f58b03ffc124fc138ad88e463) +++ tests/parameters.xotcl (.../parameters.xotcl) (revision bc6eb608936be7ce3ab17f64981902a4f51194d1) @@ -26,18 +26,20 @@ ? {::xotcl::valuecheck object o1} 1 ? {::xotcl::valuecheck integer 1} 1 + + ? {::xotcl::objectproperty o1 object} 1 + ? {::xotcl::objectproperty c1 type C} 1 + + ? {::xotcl::is c1 object -type C} 1 + ? {::xotcl::is c1 object -hasmixin M -type C} 1 + ? {::xotcl::is c1 object -hasmixin M1 -type C} 0 + ? {::xotcl::is c1 object -hasmixin M -type C0} 0 ? {::xotcl::is o1 object} 1 + ? {::xotcl::is 1 integer} 1 ? {::xotcl::is c1 type C} 1 - ? {::xotcl::is2 c1 object -type C} 1 - ? {::xotcl::is2 c1 object -hasmixin M -type C} 1 - ? {::xotcl::is2 c1 object -hasmixin M1 -type C} 0 - ? {::xotcl::is2 c1 object -hasmixin M -type C0} 0 - ? {::xotcl::is2 o1 object} 1 - ? {::xotcl::is2 1 integer} 1 - ? {::xotcl::is2 c1 type C} 1 - ? {::xotcl::is2 o type C} 0 - ? {::xotcl::is2 o object -type C} 0 - ? {::xotcl::is2 o object -hasmixin C} 0 + ? {::xotcl::is o type C} 0 + ? {::xotcl::is o object -type C} 0 + ? {::xotcl::is o object -hasmixin C} 0 #exit ? {::xotcl::valuecheck class o1} {expected class but got "o1" for parameter value} ? {::xotcl::valuecheck -nocomplain class o1} 0