From bbb80087aee557fd11cc311cb81e40e0f77099f2 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 1 Jul 2015 09:45:04 +0000 Subject: Implementation of TIP #436: Improve TclOO isa Introspection --- generic/tclOOInfo.c | 59 +++++++++++++++++++++++------------------------------ 1 file changed, 25 insertions(+), 34 deletions(-) diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 3217f98..a12208d 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -412,27 +412,25 @@ InfoObjectIsACmd( return TCL_ERROR; } - if (idx == IsObject) { - int ok = (Tcl_GetObjectFromObj(interp, objv[2]) != NULL); - - if (!ok) { - Tcl_ResetResult(interp); - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(ok ? 1 : 0)); - return TCL_OK; - } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); if (oPtr == NULL) { - return TCL_ERROR; + goto failPrecondition; } switch ((enum IsACats) idx) { + case IsObject: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "objName"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); + return TCL_OK; case IsClass: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "objName"); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->classPtr ? 1 : 0)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!oPtr->classPtr)); return TCL_OK; case IsMetaclass: if (objc != 3) { @@ -440,12 +438,12 @@ InfoObjectIsACmd( return TCL_ERROR; } if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); } else { Class *classCls = TclOOGetFoundation(interp)->classCls; - Tcl_SetObjResult(interp, Tcl_NewIntObj( - TclOOIsReachable(classCls, oPtr->classPtr) ? 1 : 0)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + TclOOIsReachable(classCls, oPtr->classPtr))); } return TCL_OK; case IsMixin: @@ -455,24 +453,19 @@ InfoObjectIsACmd( } o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]); if (o2Ptr == NULL) { - return TCL_ERROR; + goto failPrecondition; } - if (o2Ptr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "non-classes cannot be mixins", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL); - return TCL_ERROR; - } else { + if (o2Ptr->classPtr != NULL) { Class *mixinPtr; FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr == o2Ptr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); return TCL_OK; } } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); return TCL_OK; case IsType: if (objc != 4) { @@ -481,24 +474,22 @@ InfoObjectIsACmd( } o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]); if (o2Ptr == NULL) { - return TCL_ERROR; + goto failPrecondition; } if (o2Ptr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "non-classes cannot be types", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL); - return TCL_ERROR; - } - if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls))); } return TCL_OK; - case IsObject: - Tcl_Panic("unexpected fallthrough"); } return TCL_ERROR; + + failPrecondition: + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + return TCL_OK; } /* -- cgit v0.12 From 261a4a6282d0da2ebb58a4ca23d01af0968df600 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 1 Jul 2015 09:58:42 +0000 Subject: Say what is meant more clearly, put syntax checks before semantic checks. --- generic/tclOOInfo.c | 85 +++++++++++++++++++++++++++-------------------------- 1 file changed, 43 insertions(+), 42 deletions(-) diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index a12208d..0c22bcf 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -401,7 +401,7 @@ InfoObjectIsACmd( IsClass, IsMetaclass, IsMixin, IsObject, IsType }; Object *oPtr, *o2Ptr; - int idx, i; + int idx, i, result = 0; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?"); @@ -412,45 +412,53 @@ InfoObjectIsACmd( return TCL_ERROR; } - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - goto failPrecondition; - } + /* + * Now we know what test we are doing, we can check we've got the right + * number of arguments. + */ switch ((enum IsACats) idx) { case IsObject: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "objName"); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); - return TCL_OK; case IsClass: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "objName"); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!oPtr->classPtr)); - return TCL_OK; case IsMetaclass: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "objName"); return TCL_ERROR; } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); - } else { - Class *classCls = TclOOGetFoundation(interp)->classCls; - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - TclOOIsReachable(classCls, oPtr->classPtr))); - } - return TCL_OK; + break; case IsMixin: + case IsType: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "objName className"); return TCL_ERROR; } + break; + } + + /* + * Perform the check. Note that we can guarantee that we will not fail + * from here on; "failures" result in a false-TCL_OK result. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + goto failPrecondition; + } + + switch ((enum IsACats) idx) { + case IsObject: + result = 1; + break; + case IsClass: + result = (oPtr->classPtr != NULL); + break; + case IsMetaclass: + if (oPtr->classPtr != NULL) { + result = TclOOIsReachable(TclOOGetFoundation(interp)->classCls, + oPtr->classPtr); + } + break; + case IsMixin: o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]); if (o2Ptr == NULL) { goto failPrecondition; @@ -459,32 +467,25 @@ InfoObjectIsACmd( Class *mixinPtr; FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr == o2Ptr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); - return TCL_OK; + if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) { + result = 1; + break; } } } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); - return TCL_OK; + break; case IsType: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "objName className"); - return TCL_ERROR; - } o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]); if (o2Ptr == NULL) { goto failPrecondition; } - if (o2Ptr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); - } else { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls))); + if (o2Ptr->classPtr != NULL) { + result = TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls); } - return TCL_OK; + break; } - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; failPrecondition: Tcl_ResetResult(interp); -- cgit v0.12 From 9aa3e851043909a88856222ed97da6ed018a9bbe Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 2 Jul 2015 12:29:43 +0000 Subject: Revert some refcount changes on I/O structs. These are refcounts on structs, not Tcl_Obj's. Their scheme doesn't suffer the same difficulties and histories as Tcl_Obj's, and they need not copy every detail, appropriate or not, from Tcl_Obj refcount management. The "significant value" -- as dkf puts it -- for the struct refcounting scheme is 0 not 1. --- generic/tclIO.c | 4 ++-- generic/tclIOGT.c | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index eb924d1..8b2e149 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1930,7 +1930,7 @@ TclChannelRelease( if (chanPtr->refCount == 0) { Tcl_Panic("Channel released more than preserved"); } - if (chanPtr->refCount-- > 1) { + if (--chanPtr->refCount) { return; } if (chanPtr->typePtr == NULL) { @@ -2426,7 +2426,7 @@ static void ReleaseChannelBuffer( ChannelBuffer *bufPtr) { - if (bufPtr->refCount-- > 1) { + if (--bufPtr->refCount) { return; } ckfree(bufPtr); diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index c1ce485..7f61def 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -225,7 +225,7 @@ static void ReleaseData( TransformChannelData *dataPtr) { - if (dataPtr->refCount-- > 1) { + if (--dataPtr->refCount) { return; } ResultClear(&dataPtr->result); -- cgit v0.12 From 20dafdc09ed912fb421b7968b910dd44fab379d1 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 2 Jul 2015 12:54:57 +0000 Subject: Revert refcount changes that were not cosmetic. Changing equality testing to inequality testing does more than make code prettier or clearer. It makes it less strict, and thus more tolerant of other bugs elsewhere. Such changes deserve separate consideration at least, not breezy entry in an otherwise "code cleanup" commit. --- generic/tclCompile.c | 2 +- generic/tclNamesp.c | 2 +- generic/tclObj.c | 4 ++-- generic/tclPreserve.c | 4 ++-- generic/tclProc.c | 2 +- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index b9aee64..361c26f 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1117,7 +1117,7 @@ TclCleanupByteCode( } } - if (codePtr->localCachePtr && (codePtr->localCachePtr->refCount-- <= 1)) { + if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) { TclFreeLocalCache(interp, codePtr->localCachePtr); } diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 3231ce6..91239f0 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -402,7 +402,7 @@ Tcl_PopCallFrame( } if (framePtr->numCompiledLocals > 0) { TclDeleteCompiledLocalVars(iPtr, framePtr); - if (framePtr->localCachePtr->refCount-- <= 1) { + if (--framePtr->localCachePtr->refCount == 0) { TclFreeLocalCache(interp, framePtr->localCachePtr); } framePtr->localCachePtr = NULL; diff --git a/generic/tclObj.c b/generic/tclObj.c index 15d874f..f9216b3 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -4288,7 +4288,7 @@ FreeCmdNameInternalRep( * there are no more uses, free the ResolvedCmdName structure. */ - if (resPtr->refCount-- <= 1) { + if (resPtr->refCount-- == 1) { /* * Now free the cached command, unless it is still in its hash * table or if there are other references to it from other cmdName @@ -4404,7 +4404,7 @@ SetCmdNameFromAny( Command *oldCmdPtr = resPtr->cmdPtr; - if (oldCmdPtr->refCount-- <= 1) { + if (--oldCmdPtr->refCount == 0) { TclCleanupCommandMacro(oldCmdPtr); } } else { diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index 0b33d22..cca13e8 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -195,7 +195,7 @@ Tcl_Release( continue; } - if (refPtr->refCount-- > 1) { + if (--refPtr->refCount != 0) { Tcl_MutexUnlock(&preserveMutex); return; } @@ -459,7 +459,7 @@ TclHandleRelease( handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif - if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) { + if ((--handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) { ckfree(handlePtr); } } diff --git a/generic/tclProc.c b/generic/tclProc.c index a9705eb..7bf63c2 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -2445,7 +2445,7 @@ FreeLambdaInternalRep( Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; - if (procPtr->refCount-- <= 1) { + if (procPtr->refCount-- == 1) { TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); -- cgit v0.12 From b00e732483f413217639517f5964e1c518821041 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 2 Jul 2015 13:46:56 +0000 Subject: Plug leak of two mp_ints. --- generic/tclStrToD.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 66640ea..2c34866 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1922,6 +1922,8 @@ RefineApproximation( rteSignificand = frexp(approxResult, &rteExponent); rteSigWide = (Tcl_WideInt) ldexp(rteSignificand, FP_PRECISION); if ((rteSigWide & 1) == 0) { + mp_clear(&twoMd); + mp_clear(&twoMv); return approxResult; } } -- cgit v0.12 From 4ce2c3e6e7ca0a108a6b0a502f9349ce319e2c55 Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 5 Jul 2015 16:52:27 +0000 Subject: [a0ece9d6d4] The cmd field of a CmdFrame when non-NULL must point within the string of the corresponding codePtr->source. --- generic/tclExecute.c | 1 - tests/execute.test | 9 +++++++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 38f11f2..d12a25c 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9904,7 +9904,6 @@ TclGetSourceFromFrame( cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len); } else { cfPtr->cmdObj = Tcl_NewListObj(objc, objv); - cfPtr->cmd = Tcl_GetStringFromObj(cfPtr->cmdObj, &cfPtr->len); } Tcl_IncrRefCount(cfPtr->cmdObj); } diff --git a/tests/execute.test b/tests/execute.test index aaf4bc0..9a2ffbd 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -1057,6 +1057,15 @@ test execute-11.2 {Bug 268b23df11} -setup { rename crash {} rename zero {} } -result 0 +test execute-11.3 {Bug a0ece9d6d4} -setup { + proc crash {} {expr {rand()}} + trace add execution crash enterstep {apply {args {info frame -2}}} +} -body { + string is double [crash] +} -cleanup { + trace remove execution crash enterstep {apply {args {info frame -2}}} + rename crash {} +} -result 1 # cleanup if {[info commands testobj] != {}} { -- cgit v0.12 From 8037d279157b1f2f02dfe974d3d42d146ccb2194 Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 7 Jul 2015 14:16:07 +0000 Subject: Documentation: source ignores BOM for unicode files --- doc/source.n | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/source.n b/doc/source.n index 9f0fd6f..d8eaa0c 100644 --- a/doc/source.n +++ b/doc/source.n @@ -45,6 +45,8 @@ or which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP +A leading BOM (Byte order mark) contained in the file is ignored for unicode encodings (utf-8, unicode). +.PP .VS 8.5 The \fB\-encoding\fR option is used to specify the encoding of the data stored in \fIfileName\fR. When the \fB\-encoding\fR option -- cgit v0.12 From 22932eb228d4d5b49c9e2e3d7e8c7a82299a4f48 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 10 Jul 2015 12:40:49 +0000 Subject: Added tests. --- tests/oo.test | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/tests/oo.test b/tests/oo.test index f35b70a..c83e015 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2077,6 +2077,30 @@ test oo-16.13 {OO: object introspection} -setup { oo::objdefine foo method Bar {} {return "ok in foo"} [info object namespace foo]::my Bar } -result "ok in foo" +test oo-16.14 {OO: object introspection: TIP #436} -setup { + oo::class create meta { superclass oo::class } + [meta create instance1] create instance2 +} -body { + list class [list [info object isa class NOTANOBJECT] \ + [info object isa class list]] \ + meta [list [info object isa metaclass NOTANOBJECT] \ + [info object isa metaclass list] \ + [info object isa metaclass oo::object]] \ + type [list [info object isa typeof oo::object NOTANOBJECT] \ + [info object isa typeof NOTANOBJECT oo::object] \ + [info object isa typeof list NOTANOBJECT] \ + [info object isa typeof NOTANOBJECT list] \ + [info object isa typeof oo::object list] \ + [info object isa typeof list oo::object]] \ + mix [list [info object isa mixin oo::object NOTANOBJECT] \ + [info object isa mixin NOTANOBJECT oo::object] \ + [info object isa mixin list NOTANOBJECT] \ + [info object isa mixin NOTANOBJECT list] \ + [info object isa mixin oo::object list] \ + [info object isa mixin list oo::object]] +} -cleanup { + meta destroy +} -result {class {0 0} meta {0 0 0} type {0 0 0 0 0 0} mix {0 0 0 0 0 0}} test oo-17.1 {OO: class introspection} -body { info class -- cgit v0.12