Index: generic/gentclAPI.decls =================================================================== diff -u -rd03aa65bff84b01cbdd418581c35faec809cb50f -rd58e86e7557ee729a2a687854c4107d4b212cf35 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision d03aa65bff84b01cbdd418581c35faec809cb50f) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision d58e86e7557ee729a2a687854c4107d4b212cf35) @@ -51,6 +51,11 @@ xotclCmd instvar XOTclInstvarCmd { {-argName "args" -type allargs} } +xotclCmd is XOTclIsCmd { + {-argName "object" -required 1 -type tclobj} + {-argName "objectkind" -type "type|object|class|metaclass|mixin"} + {-argName "value" -required 0 -type class} +} xotclCmd methodproperty XOTclMethodPropertyCmd { {-argName "object" -required 1 -type object} {-argName "methodName" -required 1} @@ -71,6 +76,9 @@ {-argName "fromNs" -required 1 -type tclobj} {-argName "toNs" -required 1 -type tclobj} } +xotclCmd __qualify XOTclQualifyObjCmd { + {-argName "name" -required 1 -type tclobj} +} xotclCmd relation XOTclRelationCmd { {-argName "object" -required 1 -type object} {-argName "relationtype" -required 1 -type "mixin|instmixin|object-mixin|class-mixin|filter|instfilter|object-filter|class_filter|class|superclass|rootclass"} Index: generic/predefined.xotcl =================================================================== diff -u -r16696cd93d38760506be3dfc95fb2bb7ae972d2f -rd58e86e7557ee729a2a687854c4107d4b212cf35 --- generic/predefined.xotcl (.../predefined.xotcl) (revision 16696cd93d38760506be3dfc95fb2bb7ae972d2f) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision d58e86e7557ee729a2a687854c4107d4b212cf35) @@ -184,6 +184,10 @@ # instproc # # TODO mark all absolete calls at least as deprecated in library + # + # TODO move unknown handler for Class into a library, make sure that + # regression test and library function use explicit "creates". + # proc ::xotcl::info_args {inst o method} { set result [list] Index: generic/tclAPI.h =================================================================== diff -u -rd03aa65bff84b01cbdd418581c35faec809cb50f -rd58e86e7557ee729a2a687854c4107d4b212cf35 --- generic/tclAPI.h (.../tclAPI.h) (revision d03aa65bff84b01cbdd418581c35faec809cb50f) +++ generic/tclAPI.h (.../tclAPI.h) (revision d58e86e7557ee729a2a687854c4107d4b212cf35) @@ -5,6 +5,12 @@ } enum configureoptionIdx {configureoptionFilterIdx, configureoptionSoftrecreateIdx, configureoptionCacheinterfaceIdx}; +static int convertToObjectkind(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { + static CONST char *opts[] = {"type", "object", "class", "metaclass", "mixin", NULL}; + return Tcl_GetIndexFromObj(interp, objPtr, opts, "objectkind", 0, (int *)clientData); +} +enum objectkindIdx {objectkindTypeIdx, objectkindObjectIdx, objectkindClassIdx, objectkindMetaclassIdx, objectkindMixinIdx}; + static int convertToMethodproperty(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { static CONST char *opts[] = {"protected", "public", "slotobj", NULL}; return Tcl_GetIndexFromObj(interp, objPtr, opts, "methodproperty", 0, (int *)clientData); @@ -138,10 +144,12 @@ static int XOTclFinalizeObjCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclInstvarCmdStub(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 XOTclIsCmdStub(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 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 []); @@ -241,10 +249,12 @@ static int XOTclFinalizeObjCmd(Tcl_Interp *interp); static int XOTclInstvarCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int XOTclInterpObjCmd(Tcl_Interp *interp, char *name, int objc, Tcl_Obj *CONST objv[]); +static int XOTclIsCmd(Tcl_Interp *interp, Tcl_Obj *object, int objectkind, XOTclClass *value); static int XOTclMethodPropertyCmd(Tcl_Interp *interp, XOTclObject *object, char *methodName, int withPer_object, 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 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); @@ -345,10 +355,12 @@ XOTclFinalizeObjCmdIdx, XOTclInstvarCmdIdx, XOTclInterpObjCmdIdx, + XOTclIsCmdIdx, XOTclMethodPropertyCmdIdx, XOTclMyCmdIdx, XOTclNSCopyCmdsIdx, XOTclNSCopyVarsIdx, + XOTclQualifyObjCmdIdx, XOTclRelationCmdIdx, XOTclSetInstvarCmdIdx } XOTclMethods; @@ -2248,6 +2260,26 @@ } 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 )pc.clientData[1]; + XOTclClass *value = (XOTclClass *)pc.clientData[2]; + + parseContextRelease(&pc); + return XOTclIsCmd(interp, object, objectkind, value); + + } +} + +static int XOTclMethodPropertyCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -2327,6 +2359,24 @@ } static int +XOTclQualifyObjCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + + if (ArgumentParse(interp, objc, objv, NULL, objv[0], + method_definitions[XOTclQualifyObjCmdIdx].paramDefs, + method_definitions[XOTclQualifyObjCmdIdx].nrParameters, + &pc) != TCL_OK) { + return TCL_ERROR; + } else { + Tcl_Obj *name = (Tcl_Obj *)pc.clientData[0]; + + parseContextRelease(&pc); + return XOTclQualifyObjCmd(interp, name); + + } +} + +static int XOTclRelationCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -2764,6 +2814,11 @@ {"name", 0, 0, convertToString}, {"args", 0, 0, convertToNothing}} }, +{"::xotcl::is", XOTclIsCmdStub, 3, { + {"object", 1, 0, convertToTclobj}, + {"type|object|class|metaclass|mixin", 0, 0, convertToObjectkind}, + {"value", 0, 0, convertToClass}} +}, {"::xotcl::methodproperty", XOTclMethodPropertyCmdStub, 5, { {"object", 1, 0, convertToObject}, {"methodName", 1, 0, convertToString}, @@ -2784,6 +2839,9 @@ {"fromNs", 1, 0, convertToTclobj}, {"toNs", 1, 0, convertToTclobj}} }, +{"::xotcl::__qualify", XOTclQualifyObjCmdStub, 1, { + {"name", 1, 0, convertToTclobj}} +}, {"::xotcl::relation", XOTclRelationCmdStub, 3, { {"object", 1, 0, convertToObject}, {"mixin|instmixin|object-mixin|class-mixin|filter|instfilter|object-filter|class_filter|class|superclass|rootclass", 1, 0, convertToRelationtype}, Index: generic/xotcl.c =================================================================== diff -u -rd7a2ef042e35be3ce0411019edd2b7de129e7094 -rd58e86e7557ee729a2a687854c4107d4b212cf35 --- generic/xotcl.c (.../xotcl.c) (revision d7a2ef042e35be3ce0411019edd2b7de129e7094) +++ generic/xotcl.c (.../xotcl.c) (revision d58e86e7557ee729a2a687854c4107d4b212cf35) @@ -6537,21 +6537,6 @@ } -int -XOTclQualifyObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - char *string; - if (objc != 2) - return XOTclVarErrMsg(interp, "wrong # of args for __qualify", (char *) NULL); - - string = ObjStr(objv[1]); - if (!isAbsolutePath(string)) { - Tcl_SetObjResult(interp, NameInNamespaceObj(interp, string, callingNameSpace(interp))); - } else { - Tcl_SetObjResult(interp, objv[1]); - } - return TCL_OK; -} - /* * "self" object command */ @@ -7045,29 +7030,25 @@ XOTclObject *obj = (XOTclObject*)clientData; Tcl_Interp *interp; + if (!obj || !obj->teardown) return; + /*fprintf(stderr, "****** PrimitiveODestroy %p flags %.6x\n", obj, obj->flags);*/ - assert(obj && !(obj->flags & XOTCL_DELETED)); + assert(!(obj->flags & XOTCL_DELETED)); + /* destroy must have been called already */ + assert(obj->flags & XOTCL_DESTROY_CALLED); + /* * check and latch against recurrent calls with obj->teardown */ PRINTOBJ("PrimitiveODestroy", obj); - - if (!obj || !obj->teardown) return; interp = obj->teardown; /* * Don't destroy, if the interpreter is destroyed already * e.g. TK calls Tcl_DeleteInterp directly, if the window is killed */ if (Tcl_InterpDeleted(interp)) return; - /* - * call and latch user destroy with obj->id if we haven't - */ - if (!(obj->flags & XOTCL_DESTROY_CALLED)) { - fprintf(stderr, "--- final chance to call destroy ******* NEVER CALLED\n"); - callDestroyMethod(interp, obj, 0); - } #ifdef OBJDELETION_TRACE fprintf(stderr, " physical delete of %p id=%p destroyCalled=%d '%s'\n", @@ -7840,64 +7821,6 @@ } static int -XOTclIsCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = NULL; - XOTclClass *cl = NULL; - int success = 0, opt; - - static CONST char *opts[] = { - "type", "object", "class", "metaclass", "mixin", - NULL - }; - enum subCmdIdx { - typeIdx, objectIdx, classIdx, metaclassIdx, mixinIdx - }; - - if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0, &opt) != TCL_OK) { - return TCL_ERROR; - } - - switch (opt) { - case typeIdx: - if (objc != 4) return XOTclObjErrArgCnt(interp, objv[0], NULL, "type "); - success = (GetObjectFromObj(interp, objv[1], &obj) == TCL_OK - && GetClassFromObj(interp, objv[3], &cl, 0) == TCL_OK - && isSubType(obj->cl, cl)); - break; - - case objectIdx: - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, "object "); - success = (GetObjectFromObj(interp, objv[1], &obj) == TCL_OK); - break; - - case classIdx: - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, "class "); - success = (GetClassFromObj(interp, objv[1], &cl, 0) == TCL_OK); - break; - - case metaclassIdx: - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, "metaclass "); - - success = (GetObjectFromObj(interp, objv[1], &obj) == TCL_OK - && XOTclObjectIsClass(obj) - && IsMetaClass(interp, (XOTclClass*)obj, 1)); - break; - - case mixinIdx: - if (objc != 4) return XOTclObjErrArgCnt(interp, objv[0], NULL, "mixin "); - - success = (GetObjectFromObj(interp, objv[1], &obj) == TCL_OK - && GetClassFromObj(interp, objv[3], &cl, 0) == TCL_OK - && hasMixin(interp, obj, cl)); - break; - } - - Tcl_SetIntObj(Tcl_GetObjResult(interp), success); - return TCL_OK; -} - - -static int hasMixin(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl) { if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) @@ -9775,6 +9698,44 @@ return TCL_ERROR; } + +static int XOTclIsCmd(Tcl_Interp *interp, Tcl_Obj *object, int objectkind, XOTclClass *value) { + int success = TCL_ERROR; + XOTclObject *obj; + + switch (objectkind) { + case objectkindTypeIdx: + if (value == NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, "type "); + success = (GetObjectFromObj(interp, object, &obj) == TCL_OK) && isSubType(obj->cl, value); + break; + + case objectkindObjectIdx: + if (value != NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, "object "); + success = (GetObjectFromObj(interp, object, &obj) == TCL_OK); + break; + + case objectkindClassIdx: + if (value != NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, "class "); + success = (GetObjectFromObj(interp, object, &obj) == TCL_OK) && XOTclObjectIsClass(obj); + break; + + case objectkindMetaclassIdx: + if (value != NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, "metaclass "); + success = (GetObjectFromObj(interp, object, &obj) == TCL_OK) + && XOTclObjectIsClass(obj) && IsMetaClass(interp, (XOTclClass*)obj, 1); + break; + + case objectkindMixinIdx: + if (value == NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, "mixin "); + success = (GetObjectFromObj(interp, object, &obj) == TCL_OK) && + (hasMixin(interp, obj, value) == TCL_OK); + break; + } + + Tcl_SetIntObj(Tcl_GetObjResult(interp), success); + return TCL_OK; +} + static int XOTclMethodPropertyCmd(Tcl_Interp *interp, XOTclObject *object, char *methodName, int withPer_object, int methodproperty, Tcl_Obj *value) { XOTclClass *cl; @@ -10191,7 +10152,17 @@ return TCL_OK; } +static int XOTclQualifyObjCmd(Tcl_Interp *interp, Tcl_Obj *name) { + char *nameString = ObjStr(name); + if (isAbsolutePath(nameString)) { + Tcl_SetObjResult(interp, name); + } else { + Tcl_SetObjResult(interp, NameInNamespaceObj(interp, nameString, callingNameSpace(interp))); + } + return TCL_OK; +} + static int XOTclRelationCmd(Tcl_Interp *interp, XOTclObject *object, int relationtype, Tcl_Obj *value) { int oc; Tcl_Obj **ov; XOTclObject *nobj = NULL; @@ -12677,10 +12648,6 @@ Tcl_CreateObjCommand(interp, "::xotcl::unsetUnknownArgs", XOTclUnsetUnknownArgsCmd, 0,0); #endif - Tcl_CreateObjCommand(interp, "::xotcl::__qualify", XOTclQualifyObjCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::trace", XOTcl_TraceObjCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::is", XOTclIsCmd, 0, 0); - Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "self", 0); Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "next", 0); Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "my", 0); Index: generic/xotcl.decls =================================================================== diff -u -r8e5a1351ecc12dfca1e3988240a07fa745439d42 -rd58e86e7557ee729a2a687854c4107d4b212cf35 --- generic/xotcl.decls (.../xotcl.decls) (revision 8e5a1351ecc12dfca1e3988240a07fa745439d42) +++ generic/xotcl.decls (.../xotcl.decls) (revision d58e86e7557ee729a2a687854c4107d4b212cf35) @@ -101,10 +101,10 @@ char *name1, char *name2, int flgs) } -declare 22 generic { - int XOTcl_TraceObjCmd(ClientData cd, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]) -} +#declare 22 generic { +# int XOTcl_TraceObjCmd(ClientData cd, Tcl_Interp *interp, +# int objc, Tcl_Obj *CONST objv[]) +#} declare 23 generic { int XOTclErrMsg(Tcl_Interp *interp, char *msg, Tcl_FreeProc *type) } Index: generic/xotclDecls.h =================================================================== diff -u -r8e5a1351ecc12dfca1e3988240a07fa745439d42 -rd58e86e7557ee729a2a687854c4107d4b212cf35 --- generic/xotclDecls.h (.../xotclDecls.h) (revision 8e5a1351ecc12dfca1e3988240a07fa745439d42) +++ generic/xotclDecls.h (.../xotclDecls.h) (revision d58e86e7557ee729a2a687854c4107d4b212cf35) @@ -144,13 +144,7 @@ Tcl_Interp * interp, char * name1, char * name2, int flgs); #endif -#ifndef XOTcl_TraceObjCmd_TCL_DECLARED -#define XOTcl_TraceObjCmd_TCL_DECLARED -/* 22 */ -EXTERN int XOTcl_TraceObjCmd (ClientData cd, - Tcl_Interp * interp, int objc, - Tcl_Obj *CONST objv[]); -#endif +/* Slot 22 is reserved */ #ifndef XOTclErrMsg_TCL_DECLARED #define XOTclErrMsg_TCL_DECLARED /* 23 */ @@ -302,7 +296,7 @@ Tcl_Obj * (*xOTcl_ObjSetVar2) (struct XOTcl_Object * obj, Tcl_Interp * interp, Tcl_Obj * name1, Tcl_Obj * name2, Tcl_Obj * value, int flgs); /* 19 */ Tcl_Obj * (*xOTcl_ObjGetVar2) (struct XOTcl_Object * obj, Tcl_Interp * interp, Tcl_Obj * name1, Tcl_Obj * name2, int flgs); /* 20 */ int (*xOTclUnsetInstVar2) (struct XOTcl_Object * obj, Tcl_Interp * interp, char * name1, char * name2, int flgs); /* 21 */ - int (*xOTcl_TraceObjCmd) (ClientData cd, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[]); /* 22 */ + void *reserved22; int (*xOTclErrMsg) (Tcl_Interp * interp, char * msg, Tcl_FreeProc * type); /* 23 */ int (*xOTclVarErrMsg) (Tcl_Interp * interp, ...); /* 24 */ int (*xOTclErrInProc) (Tcl_Interp * interp, Tcl_Obj * objName, Tcl_Obj * clName, char * procName); /* 25 */ @@ -416,10 +410,7 @@ #define XOTclUnsetInstVar2 \ (xotclStubsPtr->xOTclUnsetInstVar2) /* 21 */ #endif -#ifndef XOTcl_TraceObjCmd -#define XOTcl_TraceObjCmd \ - (xotclStubsPtr->xOTcl_TraceObjCmd) /* 22 */ -#endif +/* Slot 22 is reserved */ #ifndef XOTclErrMsg #define XOTclErrMsg \ (xotclStubsPtr->xOTclErrMsg) /* 23 */ Index: generic/xotclStubInit.c =================================================================== diff -u -r8e5a1351ecc12dfca1e3988240a07fa745439d42 -rd58e86e7557ee729a2a687854c4107d4b212cf35 --- generic/xotclStubInit.c (.../xotclStubInit.c) (revision 8e5a1351ecc12dfca1e3988240a07fa745439d42) +++ generic/xotclStubInit.c (.../xotclStubInit.c) (revision d58e86e7557ee729a2a687854c4107d4b212cf35) @@ -58,7 +58,7 @@ XOTcl_ObjSetVar2, /* 19 */ XOTcl_ObjGetVar2, /* 20 */ XOTclUnsetInstVar2, /* 21 */ - XOTcl_TraceObjCmd, /* 22 */ + NULL, /* 22 */ XOTclErrMsg, /* 23 */ XOTclVarErrMsg, /* 24 */ XOTclErrInProc, /* 25 */ Index: generic/xotclTrace.c =================================================================== diff -u -r9f1d59741223795c836a0e8230a891781ecfc09e -rd58e86e7557ee729a2a687854c4107d4b212cf35 --- generic/xotclTrace.c (.../xotclTrace.c) (revision 9f1d59741223795c836a0e8230a891781ecfc09e) +++ generic/xotclTrace.c (.../xotclTrace.c) (revision d58e86e7557ee729a2a687854c4107d4b212cf35) @@ -104,45 +104,6 @@ } #endif -/* helper function to print the vars dynamically created on a - callframe -static void printLocalTable (CallFrame *c) { - Tcl_HashEntry *entryPtr; - Tcl_HashTable *localVarTablePtr = c->varTablePtr; - Tcl_HashSearch search; - - fprintf(stderr, "LocalVars:"); - - if (localVarTablePtr != NULL) { - for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - char *varName = Tcl_GetHashKey(localVarTablePtr, entryPtr); - fprintf(stderr, " %s,", varName); - } - } - fprintf(stderr,"\n"); -} -*/ - -int -XOTcl_TraceObjCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - char *option; - if (objc != 2) - return XOTclObjErrArgCnt(interp, objv[0], NULL, "stack|callstack"); - - option = ObjStr(objv[1]); - if (strcmp(option,"stack") == 0) { - XOTclStackDump(interp); - return TCL_OK; - } - if (strcmp(option,"callstack") == 0) { - XOTclCallStackDump(interp); - return TCL_OK; - } - return XOTclVarErrMsg(interp, "xotcltrace: unknown option", (char*) NULL); -} - void XOTclPrintObjv(char *string, int objc, Tcl_Obj *CONST objv[]) { int j;