summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog275
-rw-r--r--doc/define.n28
-rw-r--r--doc/info.n24
-rw-r--r--generic/tclOO.c22
-rw-r--r--generic/tclOODefineCmds.c96
-rw-r--r--generic/tclOOInfo.c116
-rw-r--r--generic/tclOOInt.h9
-rw-r--r--generic/tclOOMethod.c266
-rw-r--r--tests/oo.test193
9 files changed, 856 insertions, 173 deletions
diff --git a/ChangeLog b/ChangeLog
index 85c46a1..8eea436 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,37 +1,55 @@
+2008-09-22 Donal K. Fellows <dkf@users.sf.net>
+
+ TIP #320 IMPLEMENTATION
+
+ * generic/tclOODefineCmds.c (TclOODefineVariablesObjCmd):
+ * generic/tclOOInfo.c (InfoObjectVariablesCmd, InfoClassVariablesCmd):
+ * generic/tclOOMethod.c (TclOOSetupVariableResolver, etc):
+ * doc/define.n, doc/ooInfo.n, benchmarks/cps.tcl:
+ * tests/oo.test (oo-26.*): Allow the declaration of the common
+ variables used in methods of a class or object. These are then mapped
+ in using a variable resolver. This makes many class declarations much
+ simpler overall, encourages good usage of variable names, and also
+ boosts speed a bit.
+
+ * generic/tclOOMethod.c (TclOOGetMethodBody): Factor out the code to
+ get the body of a procedure-like method. Reduces the amount of "poking
+ inside the abstraction" that is done by the introspection code.
+
2008-09-22 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * doc/chan.n: clean up paragraph order.
+
+ * doc/chan.n: Clean up paragraph order.
2008-09-18 Miguel Sofer <msofer@users.sf.net>
* generic/tclExecute.c (NEXT_INST_F):
- * generic/tclInt.h (TCL_CT_ASSERT): new compile-time assertions,
+ * generic/tclInt.h (TCL_CT_ASSERT): New compile-time assertions,
adapted from www.pixelbeat.org/programming/gcc/static_assert.html
2008-09-17 Don Porter <dgp@users.sourceforge.net>
- * generic/tclInt.h: Correct the TclGetLongFromObj,
- TclGetIntFromObj, and TclGetIntForIndexM macros so that they
- retrieve the internalRep.longValue field instead of casting the
- internalRep.otherValuePtr field to type long.
+ * generic/tclInt.h: Correct the TclGetLongFromObj, TclGetIntFromObj,
+ and TclGetIntForIndexM macros so that they retrieve the longValue
+ field from the internalRep instead of casting the otherValuePtr field
+ to type long.
2008-09-17 Miguel Sofer <msofer@users.sf.net>
* library/init.tcl: export min and max commands from the mathfunc
- namespace [Bug 2116053]
+ namespace. [Bug 2116053]
2008-09-16 Joe Mistachkin <joe@mistachkin.com>
- * generic/tclParse.c: move TclResetCancellation to be called on
+ * generic/tclParse.c: Move TclResetCancellation to be called on
returning to level 0, as opposed to it being called on starting a
substitution at level 0.
2008-09-16 Miguel Sofer <msofer@users.sf.net>
- * generic/tclBasic.c: move TclResetCancellation to be called on
+ * generic/tclBasic.c: Move TclResetCancellation to be called on
returning to level 0, as opposed to it being called on starting a
- command at level 0. Add a call on returning via Tcl_EvalObjEx to
- fix [Bug 2114165].
+ command at level 0. Add a call on returning via Tcl_EvalObjEx to fix
+ [Bug 2114165].
2008-09-10 Donal K. Fellows <dkf@users.sf.net>
@@ -45,13 +63,13 @@
2008-09-10 Miguel Sofer <msofer@users.sf.net>
- * tests/nre.test: add missing constraints; enable test of foreach
- recursion.
+ * tests/nre.test: Add missing constraints; enable test of foreach
+ recursion.
* generic/tclBasic.c:
* generic/tclCompile.h:
- * generic/tclExecute.c (INST_EVAL_STK): fix for [Bug 2102930],
- wrong numLevels when evaling a canonical list.
+ * generic/tclExecute.c (INST_EVAL_STK): Wrong numLevels when evaling a
+ canonical list. [Bug 2102930]
2008-09-10 Donal K. Fellows <dkf@users.sf.net>
@@ -68,24 +86,23 @@
2008-09-07 Miguel Sofer <msofer@users.sf.net>
* generic/tclCompile.c (TclCompileTokens):
- * generic/tclExecute.c (CompileExprObj): fix a perf bug (found by
- Alex Ferrieux) where some variables in the LVT where not being
- accessed by index. Fix missing localCache management in compiled
- expressions found while analyzing the bug.
-
+ * generic/tclExecute.c (CompileExprObj): Fix a perf bug (found by Alex
+ Ferrieux) where some variables in the LVT where not being accessed by
+ index. Fix missing localCache management in compiled expressions found
+ while analyzing the bug.
+
2008-09-07 Miguel Sofer <msofer@users.sf.net>
- * doc/namespace.n: fix [Bug 2098441]
+ * doc/namespace.n: Fix [Bug 2098441]
2008-09-04 Miguel Sofer <msofer@users.sf.net>
* generic/tclTrace.test (TraceVarProc):
- * generic/unsupported.test: insure that unset traces are run even
- when the coroutine is unwinding [Bug 2093947]
-
- * generic/tclExecute.c (CACHE_STACK_INFO):
- * tests/unsupported.test: restore the execEnv's bottomPtr, fix
- for [Bug 2093188].
+ * generic/unsupported.test: Insure that unset traces are run even when
+ the coroutine is unwinding. [Bug 2093947]
+
+ * generic/tclExecute.c (CACHE_STACK_INFO):
+ * tests/unsupported.test: Restore execEnv's bottomPtr. [Bug 2093188]
2008-09-02 Don Porter <dgp@users.sourceforge.net>
@@ -106,15 +123,15 @@
2008-09-01 Miguel Sofer <msofer@users.sf.net>
- * generic/tclCmdAH.c: nre-enabling [eval]; eval scripts are now
- * generic/tclOOBasic.c: bytecompiled. Adapted recursion limit tests
- * tests/interp.test: that were relying on eval not being
- * tests/nre.test: compiled. Part of the [Bug 2017632] project.
+ * generic/tclCmdAH.c: NRE-enabling [eval]; eval scripts are now
+ * generic/tclOOBasic.c: bytecompiled. Adapted recursion limit tests
+ * tests/interp.test: that were relying on eval not being
+ * tests/nre.test: compiled. Part of the [Bug 2017632] project.
* tests/unsupported.test:
2008-09-01 Donal K. Fellows <dkf@users.sf.net>
- * generic/tclOOMethod.c (InvokeProcedureMethod):
+ * generic/tclOOMethod.c (InvokeProcedureMethod):
* generic/tclOO.c (ObjectRenamedTrace): Arrange for only methods that
involve callbacks into the Tcl interpreter to be skipped when the
interpreter is being torn down. Allows the semantics of destructors in
@@ -124,8 +141,8 @@
* unix/Makefile.in: Ensure that all TclOO headers get installed.
* win/Makefile.in: [Bug 2082299]
- * win/makefile.bc:
- * win/makefile.vc:
+ * win/makefile.bc:
+ * win/makefile.vc:
2008-08-28 Don Porter <dgp@users.sourceforge.net>
@@ -147,16 +164,16 @@
2008-08-26 Miguel Sofer <msofer@users.sf.net>
- * generic/tclBasic.c (InfoCoroutine):
- * tests/unsupported.test: new command that returns the
- FQN of the currently executing coroutine. Lives as infoCoroutine
- under unsupported, but is designed to become a subcommand of [info]
+ * generic/tclBasic.c (InfoCoroutine):
+ * tests/unsupported.test: New command that returns the FQN of the
+ currently executing coroutine. Lives as infoCoroutine under
+ unsupported, but is designed to become a subcommand of [info]
2008-08-23 Miguel Sofer <msofer@users.sf.net>
- * generic/tclBasic.c (NRInterpCoroutine): store the caller's
- eePtr, stop assuming the coroutine is invoked from the same
- execEnv where it was created.
+ * generic/tclBasic.c (NRInterpCoroutine): Store the caller's eePtr,
+ stop assuming the coroutine is invoked from the same execEnv where it
+ was created.
2008-08-24 Donal K. Fellows <dkf@users.sf.net>
@@ -167,11 +184,11 @@
2008-08-23 Miguel Sofer <msofer@users.sf.net>
- * generic/tclBasic.c: Removed unused var; fixed function
- * generic/tclOOInt.h: pointer declarations (why did gcc start
- * generic/tclOOMethod.c: complaining all of a sudden?)
+ * generic/tclBasic.c: Removed unused var; fixed function pointer
+ * generic/tclOOInt.h: declarations (why did gcc start complaining
+ * generic/tclOOMethod.c: all of a sudden?)
* generic/tclProc.c:
-
+
2008-08-23 Donal K. Fellows <dkf@users.sf.net>
* generic/tclInt.h (EnsembleImplMap): Added extra field to make it
@@ -184,7 +201,7 @@
2008-08-22 Miguel Sofer <msofer@users.sf.net>
- * generic/tclBasic.c:
+ * generic/tclBasic.c:
* generic/tclExecute.c: Set special errocodes: COROUTINE_BUSY,
COROUTINE_CANT_YIELD, COROUTINE_ILLEGAL_YIELD.
@@ -198,28 +215,28 @@
indirection without value. Use -DCONST86="" to engage source compat
support for code written for 8.5 headers.
- * generic/tclUtil.c (TclReToGlob): Added missing set of the
+ * generic/tclUtil.c (TclReToGlob): Added missing set of the
*exactPtr value to really fix [Bug 2065115]. Also avoid possible
DString overflow.
- * tests/regexpComp.test: Correct duplicate test names.
+ * tests/regexpComp.test: Correct duplicate test names.
2008-08-21 Miguel Sofer <msofer@users.sf.net>
- * generic/tclBasic.c: Previous fix, now done right.
+ * generic/tclBasic.c: Previous fix, now done right.
* generic/tclCmdIL.c:
- * generic/tclInt.h:
+ * generic/tclInt.h:
* tests/unsupported.test:
2008-08-21 Jeff Hobbs <jeffh@ActiveState.com>
- * tests/regexp.test, tests/regexpComp.test: correct re2glob ***=
- * generic/tclUtil.c (TclReToGlob): translation from exact
+ * tests/regexp.test, tests/regexpComp.test: Correct re2glob ***=
+ * generic/tclUtil.c (TclReToGlob): translation from exact
to anywhere-in-string match. [Bug 2065115]
2008-08-21 Don Porter <dgp@users.sourceforge.net>
- * generic/tcl.h: Reduced the use of CONST86 and eliminated
- * generic/tcl.decls: the use of CONST86_RETURN to support source
+ * generic/tcl.h: Reduced the use of CONST86 and eliminated
+ * generic/tcl.decls: the use of CONST86_RETURN to support source
code compatibility with Tcl 8.5 on those public routines passing
(Tcl_Filesystem *), (Tcl_Timer *), and (Tcl_Objtype *) values which
have been const-ified. What remains is the minimum configurability
@@ -233,7 +250,7 @@
* generic/tclBasic.c: Fix the cmdFrame level count in
* generic/tclCmdIL.c: coroutines. Fix small bug on coroutine
- * generic/tclInt.h: rewind.
+ * generic/tclInt.h: rewind.
2008-08-21 Donal K. Fellows <dkf@users.sf.net>
@@ -243,7 +260,7 @@
2008-08-21 Pat Thoyts <patthoyts@users.sourceforge.net>
* generic/tclOOMethod.c: Added casts to make MSVC happy
- * generic/tclBasic.c:
+ * generic/tclBasic.c:
2008-08-20 Donal K. Fellows <dkf@users.sf.net>
@@ -265,8 +282,8 @@
2008-08-17 Miguel Sofer <msofer@users.sf.net>
- * generic/tclBasic.c: Implementation of [coroutine] and [yield]
- * generic/tclCmdAH.c: commands (in tcl::unsupported).
+ * generic/tclBasic.c: Implementation of [coroutine] and [yield]
+ * generic/tclCmdAH.c: commands (in tcl::unsupported).
* generic/tclCompile.h:
* generic/tclExecute.c:
* generic/tclInt.h:
@@ -333,8 +350,8 @@
2008-08-13 Don Porter <dgp@users.sourceforge.net>
- * generic/tclFileName.c: Fix for errors handling -types {}
- * tests/fileName.test: option to [glob]. [Bug 1750300]
+ * generic/tclFileName.c: Fix for errors handling -types {}
+ * tests/fileName.test: option to [glob]. [Bug 1750300]
Thanks to Matthias Kraft and George Peter Staplin.
2008-08-12 Jeff Hobbs <jeffh@ActiveState.com>
@@ -389,17 +406,17 @@
2008-08-11 Don Porter <dgp@users.sourceforge.net>
- * library/http/http.tcl: Bump http version to 2.7.1 to account
- * library/http/pkgIndex.tcl: for [Bug 2046486] bug fix. This
- * unix/Makefile.in: release of http now requires a
- * win/Makefile.in: dependency on Tcl 8.5 to be able to
- * win/makefile.bc: use the unsigned formats in the
- * win/makefile.vc: [binary scan] command.
+ * library/http/http.tcl: Bump http version to 2.7.1 to account
+ * library/http/pkgIndex.tcl: for [Bug 2046486] bug fix. This
+ * unix/Makefile.in: release of http now requires a
+ * win/Makefile.in: dependency on Tcl 8.5 to be able to
+ * win/makefile.bc: use the unsigned formats in the
+ * win/makefile.vc: [binary scan] command.
2008-08-11 Pat Thoyts <patthoyts@users.sourceforge.net>
* library/http/http.tcl: CRC field from zlib data should be treated as
- unsigned for 64bit support [Bug 2046846]
+ unsigned for 64bit support. [Bug 2046846]
2008-08-10 Miguel Sofer <msofer@users.sf.net>
@@ -410,7 +427,7 @@
2008-08-09 Miguel Sofer <msofer@users.sf.net>
- * generic/tclBasic.c: Slight cleanup
+ * generic/tclBasic.c: Slight cleanup
* generic/tclCompile.h:
* generic/tclExecute.c:
@@ -490,25 +507,25 @@
for [foreach] has been added and marked as knownbug, awaiting for it
to be NR-enabled.
- * generic/tclBasic.c: Made atProcExit commands run
- * generic/tclCompile.h: inconditionally, streamlined
- * generic/tclExecute.c: atProcExit/tailcall processing
- * generic/tclProc.c: in TEBC.
+ * generic/tclBasic.c: Made atProcExit commands run
+ * generic/tclCompile.h: unconditionally, streamlined
+ * generic/tclExecute.c: atProcExit/tailcall processing in TEBC.
+ * generic/tclProc.c:
* tests/unsupported.test:
-2008-08-04 Don Porter <dgp@users.sourceforge.net>
+2008-08-04 Don Porter <dgp@users.sourceforge.net>
* generic/tclExecute.c: Stopped faulty double-logging of errors to
- * tests/execute.test: stack trace when a compile epoch bump triggers
+ * tests/execute.test: stack trace when a compile epoch bump triggers
fallback to direct evaluation of commands in a compiled script.
[Bug 2037338]
2008-08-03 Miguel Sofer <msofer@users.sf.net>
- * generic/tclBasic.c: New unsupported command atProcExit
- * generic/tclCompile.h: that shares the implementation with
- * generic/tclExecute.c: tailcall. Fixed a segfault in
- * generic/tclInt.h: tailcalls. Tests added.
+ * generic/tclBasic.c: New unsupported command atProcExit that
+ * generic/tclCompile.h: shares the implementation with tailcall.
+ * generic/tclExecute.c: Fixed a segfault in tailcalls. Tests added.
+ * generic/tclInt.h:
* generic/tclInterp.c:
* generic/tclNamesp.c:
* tests/unsupported.test:
@@ -521,9 +538,9 @@
2008-08-01 Jeff Hobbs <jeffh@ActiveState.com>
- * doc/Exit.3: Do not call Tcl_Finalize implicitly
- * generic/tclEvent.c: on DLL_PROCESS_DETACH as it may lead
- * win/tclWin32Dll.c (DllMain): to issues and the user should be
+ * doc/Exit.3: Do not call Tcl_Finalize implicitly
+ * generic/tclEvent.c: on DLL_PROCESS_DETACH as it may lead
+ * win/tclWin32Dll.c (DllMain): to issues and the user should be
explicitly calling Tcl_Finalize before unloading regardless. Clarify
the docs to note the explicit need in embedded use.
@@ -564,7 +581,7 @@
2008-07-30 Miguel Sofer <msofer@users.sf.net>
- * generic/tclBasic.c: Improved tailcalls.
+ * generic/tclBasic.c: Improved tailcalls.
* generic/tclCompile.h:
* generic/tclExecute.c:
* generic/tclTest.c:
@@ -581,55 +598,53 @@
* tests/NRE.test: New tests that went MIA in the NRE revamping
- * generic/tclBasic.c: Clean up
+ * generic/tclBasic.c: Clean up
* generic/tclNRE.h:
* generic/tclExecute.c:
- * generic/tclBasic.c: Made use of the thread's alloc cache
- * generic/tclInt.h: stored in the ekeko at interp creation
- * generic/tclNRE.h: to avoid hitting the TSD each time an
- * generic/tclThreadAlloc.c: NRE callback is pushed or pulled; the
- approach is suitably general to extend to evry other obj
- allocation where an interp is know; this is left for some other
- time, requires a lot of grunt work.
+ * generic/tclBasic.c: Made use of the thread's alloc cache stored in
+ * generic/tclInt.h: the ekeko at interp creation to avoid hitting
+ * generic/tclNRE.h: the TSD each time an NRE callback is pushed or
+ * generic/tclThreadAlloc.c: pulled; the approach is suitably general
+ to extend to every other obj allocation where an interp is know; this
+ is left for some other time, requires a lot of grunt work.
- * generic/tclExecute.c: Fix [Bug 2030670] that cause
- TclStackRealloc to panic on rare corner cases. Thx ajpasadyn for
- diagnose and patch.
+ * generic/tclExecute.c: Fix [Bug 2030670] that cause TclStackRealloc
+ to panic on rare corner cases. Thx ajpasadyn for diagnose and patch.
- * generic/tcl.decls: Completely revamped NRE implementation,
- * generic/tclBasic.c: with (almost) unchanged API.
+ * generic/tcl.decls: Completely revamped NRE implementation, with
+ * generic/tclBasic.c: (almost) unchanged API.
* generic/tclCompile.h:
- * generic/tclExecute.c: TEBC will require a bit of a facelift,
- * generic/tclInt.decls: but TEOV at least looks great now.
- * generic/tclInt.h: There are new tests (incomplete!) to verify
- * generic/tclInterp.c: that execution is indeed in the same TEBC
- * generic/tclNRE.h: instance, at the same level in all stacks
- * generic/tclNamesp.c: involved. Tailcalls are still a bit leaky,
- * generic/tclOOBasic.c: still deserving to be in tcl::unsupported.
+ * generic/tclExecute.c: TEBC will require a bit of a facelift, but
+ * generic/tclInt.decls: TEOV at least looks great now. There are new
+ * generic/tclInt.h: tests (incomplete!) to verify that execution
+ * generic/tclInterp.c: is indeed in the same TEBC instance, at the
+ * generic/tclNRE.h: same level in all stacks involved. Tailcalls
+ * generic/tclNamesp.c: are still a bit leaky, still deserving to be
+ * generic/tclOOBasic.c: in tcl::unsupported.
* generic/tclOOMethod.c:
- * generic/tclProc.c: Uninit'd var warnings in TEBC with -O2, no
- * generic/tclTest.c: warnings otherwise.
+ * generic/tclProc.c: Uninit'd var warnings in TEBC with -O2, no
+ * generic/tclTest.c: warnings otherwise.
2008-07-28 Jan Nijtmans <nijtmans@users.sf.net>
- * doc/FileSystem.3: CONSTified many functions using
- * generic/tcl.decls: Tcl_FileSystem which all are supposed to be
- * generic/tclDecls.h: a constant, but this was not reflected
- * generic/tclFileSystem.h: in the API: Tcl_FSGetInternalRep,
- * generic/tclIOUtil.c: Tcl_FSNewNativePath, Tcl_FSData,
- * generic/tclPathObj.c: Tcl_FSRegister, Tcl_FSUnregister,
- * generic/tclTest.c: Tcl_FSGetFileSystemForPath ...
+ * doc/FileSystem.3: CONSTified many functions using
+ * generic/tcl.decls: Tcl_FileSystem which all are supposed
+ * generic/tclDecls.h: to be a constant, but this was not
+ * generic/tclFileSystem.h: reflected in the API: Tcl_FSData,
+ * generic/tclIOUtil.c: Tcl_FSGetInternalRep, Tcl_FSRegister,
+ * generic/tclPathObj.c: Tcl_FSNewNativePath, Tcl_FSUnregister,
+ * generic/tclTest.c: Tcl_FSGetFileSystemForPath ...
This change complies with TIP #27.
***POTENTIAL INCOMPATIBILITY***
2008-07-28 Andreas Kupries <andreask@activestate.com>
- * generic/tclBasic.c: Added missing ref count when creating an
- empty string as path (TclEvalEx). In 8.4 the missing code caused
- panics in the testsuite. It doesn't in 8.5. I am guessing that the
- code path with the missing the incr-refcount is not invoked any
- longer. Because the bug in itself is certainly the same.
+ * generic/tclBasic.c: Added missing ref count when creating an empty
+ string as path (TclEvalEx). In 8.4 the missing code caused panics in
+ the testsuite. It doesn't in 8.5. I am guessing that the code path
+ with the missing the incr-refcount is not invoked any longer. Because
+ the bug in itself is certainly the same.
2008-07-27 Donal K. Fellows <dkf@users.sf.net>
@@ -638,15 +653,15 @@
2008-07-27 Jan Nijtmans <nijtmans@users.sf.net>
- * doc/Object.3: CONSTified 3 functions using Tcl_ObjType
- * doc/ObjectType.3: which all are supposed to be a constant, but
- * generic/tcl.decls: this was not reflected in the API:
- * generic/tcl.h: Tcl_ConvertToType, Tcl_GetObjType,
- * generic/tclDecls.h: Tcl_RegisterObjType
- * generic/tclObj.c: Introduced a CONST86_RETURN, so extensions
+ * doc/Object.3: CONSTified 3 functions using Tcl_ObjType
+ * doc/ObjectType.3: which all are supposed to be a constant, but
+ * generic/tcl.decls: this was not reflected in the API:
+ * generic/tcl.h: Tcl_RegisterObjType, Tcl_ConvertToType,
+ * generic/tclDecls.h: Tcl_GetObjType
+ * generic/tclObj.c: Introduced a CONST86_RETURN, so extensions
* generic/tclCompCmds.c: which use Tcl_ObjType directly can be
* generic/tclOOMethod.c: modified to compile against both Tcl 8.5 and
- * generic/tclTestobj.c: Tcl 8.6. tclDecls.h regenerated
+ * generic/tclTestobj.c: Tcl 8.6. tclDecls.h regenerated
This change complies with TIP #27.
***POTENTIAL INCOMPATIBILITY***
@@ -907,9 +922,9 @@
2008-07-15 Miguel Sofer <msofer@users.sf.net>
- * tests/NRE.test: Better constraint for testing the existence of
- * tests/stack.test: teststacklimit, to insure that the test suite
- runs under tclsh.
+ * tests/NRE.test: Better constraint for testing the existence of
+ * tests/stack.test: teststacklimit, to insure that the test suite
+ runs under tclsh.
* generic/tclParse.c: fixing incomplete reversion of "fix" for [Bug
2017583], missing TclResetCancellation call.
@@ -1686,17 +1701,17 @@
2008-04-09 Daniel Steffen <das@users.sourceforge.net>
- * tests/chanio.test (chan-io-53.8,53.9,53.10): fix typo & quoting for
+ * tests/chanio.test (chan-io-53.8,53.9,53.10): Fix typo & quoting for
* tests/io.test (io-53.8,53.9,53.10): spaces in builddir path
2008-04-08 Miguel Sofer <msofer@users.sf.net>
- * generic/tclExecute.c: added comments to the alignment macros used in
+ * generic/tclExecute.c: Added comments to the alignment macros used in
GrowEvaluationStack() and friends.
2008-04-08 Daniel Steffen <das@users.sourceforge.net>
- * tools/genStubs.tcl: revert erroneous 2008-04-02 change marking
+ * tools/genStubs.tcl: Revert erroneous 2008-04-02 change marking
*StubsPtr as EXTERN instead of extern.
* generic/tclDecls.h: make genstubs
diff --git a/doc/define.n b/doc/define.n
index a1a92bf..ddbf476 100644
--- a/doc/define.n
+++ b/doc/define.n
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: define.n,v 1.1 2008/05/31 11:42:12 dkf Exp $
+'\" RCS: @(#) $Id: define.n,v 1.2 2008/09/23 05:05:47 dkf Exp $
'\"
.so man.macros
.TH define n 0.3 TclOO "TclOO Commands"
@@ -157,6 +157,20 @@ but instead just through the \fBmy\fR command visible in each object's
context) by the class being defined. Note that the methods themselves may be
actually defined by a superclass; subclass unexports override superclass
visibility, and may be overridden by instance unexports.
+.TP
+\fBvariable\fR ?\fIname ...\fR?
+.VS
+This arranges for each of the named variables to be automatically made
+available in the methods, constructor and destructor declared by the class
+being defined. Note that the list of variable names is the whole list of
+variable names for the class. Each variable name must not have any namespace
+separators and must not look like an array access. All variables will be
+actually present in the instance object on which the method is executed. Note
+that the variable lists declared by a superclass or subclass are completely
+disjoint, as are variable lists declared by instances; the list of variable
+names is just for methods (and constructors and destructors) declared by this
+class.
+.VE
.SS "CONFIGURING OBJECTS"
.PP
The following commands are supported in the \fIdefScript\fR for
@@ -233,6 +247,18 @@ This arranges for each of the named methods, \fIname\fR, to be not exported
just through the \fBmy\fR command visible in the object's context) by the
object being defined. Note that the methods themselves may be actually defined
by a class; instance unexports override class visibility.
+.TP
+\fBvariable\fR ?\fIname ...\fR?
+.VS
+This arranges for each of the named variables to be automatically made
+available in the methods declared by the object being defined. Note that the
+list of variable names is the whole list of variable names for the object.
+Each variable name must not have any namespace separators and must not look
+like an array access. All variables will be actually present in the object on
+which the method is executed. Note that the variable lists declared by the
+classes and mixins of which the object is an instance are completely disjoint;
+the list of variable names is just for methods declared by this object.
+.VE
.SH EXAMPLES
This example demonstrates how to use both forms of the \fBoo::define\fR and
\fBoo::objdefine\fR commands (they work in the same way), as well as
diff --git a/doc/info.n b/doc/info.n
index 0a53823..6200357 100644
--- a/doc/info.n
+++ b/doc/info.n
@@ -8,7 +8,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: info.n,v 1.27 2008/06/29 22:28:24 dkf Exp $
+'\" RCS: @(#) $Id: info.n,v 1.28 2008/09/23 05:05:47 dkf Exp $
'\"
.so man.macros
.TH info n 8.4 Tcl "Tcl Built-In Commands"
@@ -453,6 +453,13 @@ match\fR.
.VS 8.6
This subcommand returns a list of direct superclasses of class \fIclass\fR in
inheritance precedence order.
+.VE 8.6
+.TP
+\fBinfo class variables\fI class\fR
+.VS 8.6
+This subcommand returns a list of all variables that have been declared for
+the class named \Iclass\fR (i.e. that are automatically present in the
+class's methods, constructor and destructor).
.SS "OBJECT INTROSPECTION"
.PP
The following \fIsubcommand\fR values are supported by \fBinfo object\fR:
@@ -552,12 +559,23 @@ This subcommand returns a list of all classes that have been mixed into the
object named \fIobject\fR.
.VE 8.6
.TP
+\fBinfo object variables\fI object\fR
+.VS 8.6
+This subcommand returns a list of all variables that have been declared for
+the object named \fIobject\fR (i.e. that are automatically present in the
+object's methods).
+.VE 8.6
+.TP
\fBinfo object vars\fI object\fR ?\fIpattern\fR?
.VS 8.6
This subcommand returns a list of all variables in the private namespace of
the object named \fIobject\fR. If the optional \fIpattern\fR argument is
given, it is a filter (in the syntax of a \fBstring match\fR glob pattern)
-that constrains the list of variables returned.
+that constrains the list of variables returned. Note that this is different
+from the lit returned by \fBinfo object variables\fR; that can include
+variables that are currently unset, whereas this can include variables that
+are not automatically included by any of \fIobject\fR's methods (or those of
+its class, superclasses or mixins).
.VE 8.6
.SH EXAMPLES
.PP
@@ -617,7 +635,7 @@ proc getDef {obj method} {
.VE 8.6
.SH "SEE ALSO"
.VS 8.6
-global(n), oo::class(n), oo::object(n), proc(n), self(n)
+global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n)
.VE 8.6
.SH KEYWORDS
command, information, interpreter, introspection, level, namespace,
diff --git a/generic/tclOO.c b/generic/tclOO.c
index b25f070..11a7cbd 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOO.c,v 1.16 2008/09/01 00:35:42 dkf Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.17 2008/09/23 05:05:48 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -38,6 +38,7 @@ static const struct {
{"self", TclOODefineSelfObjCmd, 0},
{"superclass", TclOODefineSuperclassObjCmd, 0},
{"unexport", TclOODefineUnexportObjCmd, 0},
+ {"variable", TclOODefineVariablesObjCmd, 0},
{NULL, NULL, 0}
}, objdefCmds[] = {
{"class", TclOODefineClassObjCmd, 1},
@@ -49,6 +50,7 @@ static const struct {
{"mixin", TclOODefineMixinObjCmd, 1},
{"renamemethod", TclOODefineRenameMethodObjCmd, 1},
{"unexport", TclOODefineUnexportObjCmd, 1},
+ {"variable", TclOODefineVariablesObjCmd, 1},
{NULL, NULL, 0}
};
@@ -453,6 +455,7 @@ AllocObject(
configNamespace:
TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
+ TclOOSetupVariableResolver(oPtr->namespacePtr);
/*
* Suppress use of compiled versions of the commands in this object's
@@ -761,7 +764,7 @@ ObjectNamespaceDeleted(
FOREACH_HASH_DECLS;
Class *clsPtr = oPtr->classPtr, *mixinPtr;
Method *mPtr;
- Tcl_Obj *filterObj;
+ Tcl_Obj *filterObj, *variableObj;
int i, preserved = !(oPtr->flags & OBJECT_DELETED);
/*
@@ -808,6 +811,13 @@ ObjectNamespaceDeleted(
ckfree((char *) oPtr->methodsPtr);
}
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i) {
+ ckfree((char *) oPtr->variables.list);
+ }
+
if (oPtr->chainCache) {
TclOODeleteChainCache(oPtr->chainCache);
}
@@ -889,6 +899,14 @@ ObjectNamespaceDeleted(
Tcl_DeleteHashTable(&clsPtr->classMethods);
TclOODelMethodRef(clsPtr->constructorPtr);
TclOODelMethodRef(clsPtr->destructorPtr);
+
+ FOREACH(variableObj, clsPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i) {
+ ckfree((char *) clsPtr->variables.list);
+ }
+
DelRef(clsPtr);
}
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 77f9970..fe7e8de 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOODefineCmds.c,v 1.4 2008/05/31 11:42:18 dkf Exp $
+ * RCS: @(#) $Id: tclOODefineCmds.c,v 1.5 2008/09/23 05:05:54 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -1792,6 +1792,100 @@ TclOODefineUnexportObjCmd(
return TCL_OK;
}
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineVariablesObjCmd --
+ * Implementation of the "variable" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineVariablesObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstanceVars = (clientData != NULL);
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *variableObj;
+ int i;
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!isInstanceVars && !oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ return TCL_ERROR;
+ }
+
+ for (i=1 ; i<objc ; i++) {
+ const char *varName = Tcl_GetString(objv[i]);
+
+ if (strstr(varName, "::") != NULL) {
+ Tcl_AppendResult(interp, "invalid declared variable name \"",
+ varName, "\": must not contain namespace separators",
+ NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_StringMatch(varName, "*(*)")) {
+ Tcl_AppendResult(interp, "invalid declared variable name \"",
+ varName, "\": must not refer to an array element", NULL);
+ return TCL_ERROR;
+ }
+ }
+ for (i=1 ; i<objc ; i++) {
+ Tcl_IncrRefCount(objv[i]);
+ }
+
+ if (!isInstanceVars) {
+ FOREACH(variableObj, oPtr->classPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i != objc-1) {
+ if (objc == 1) {
+ ckfree((char *) oPtr->classPtr->variables.list);
+ } else if (i) {
+ oPtr->classPtr->variables.list = (Tcl_Obj **)
+ ckrealloc((char *) oPtr->classPtr->variables.list,
+ sizeof(Tcl_Obj *) * (objc-1));
+ } else {
+ oPtr->classPtr->variables.list = (Tcl_Obj **)
+ ckalloc(sizeof(Tcl_Obj *) * (objc-1));
+ }
+ }
+ if (objc > 1) {
+ memcpy(oPtr->classPtr->variables.list, objv+1,
+ sizeof(Tcl_Obj *) * (objc-1));
+ }
+ oPtr->classPtr->variables.num = objc-1;
+ } else {
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i != objc-1) {
+ if (objc == 1) {
+ ckfree((char *) oPtr->variables.list);
+ } else if (i) {
+ oPtr->variables.list = (Tcl_Obj **)
+ ckrealloc((char *) oPtr->variables.list,
+ sizeof(Tcl_Obj *) * (objc-1));
+ } else {
+ oPtr->variables.list = (Tcl_Obj **)
+ ckalloc(sizeof(Tcl_Obj *) * (objc-1));
+ }
+ }
+ if (objc > 1) {
+ memcpy(oPtr->variables.list, objv+1, sizeof(Tcl_Obj *)*(objc-1));
+ }
+ oPtr->variables.num = objc-1;
+ }
+ return TCL_OK;
+}
+
void
Tcl_ClassSetConstructor(
Tcl_Interp *interp,
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index bc7b4fb..41d90a4 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOOInfo.c,v 1.6 2008/08/12 23:19:15 hobbs Exp $
+ * RCS: @(#) $Id: tclOOInfo.c,v 1.7 2008/09/23 05:05:54 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -26,6 +26,7 @@ static Tcl_ObjCmdProc InfoObjectIsACmd;
static Tcl_ObjCmdProc InfoObjectMethodsCmd;
static Tcl_ObjCmdProc InfoObjectMixinsCmd;
static Tcl_ObjCmdProc InfoObjectVarsCmd;
+static Tcl_ObjCmdProc InfoObjectVariablesCmd;
static Tcl_ObjCmdProc InfoClassConstrCmd;
static Tcl_ObjCmdProc InfoClassDefnCmd;
static Tcl_ObjCmdProc InfoClassDestrCmd;
@@ -36,6 +37,7 @@ static Tcl_ObjCmdProc InfoClassMethodsCmd;
static Tcl_ObjCmdProc InfoClassMixinsCmd;
static Tcl_ObjCmdProc InfoClassSubsCmd;
static Tcl_ObjCmdProc InfoClassSupersCmd;
+static Tcl_ObjCmdProc InfoClassVariablesCmd;
struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; };
@@ -51,6 +53,7 @@ static const struct NameProcMap infoObjectCmds[] = {
{"::oo::InfoObject::isa", InfoObjectIsACmd},
{"::oo::InfoObject::methods", InfoObjectMethodsCmd},
{"::oo::InfoObject::mixins", InfoObjectMixinsCmd},
+ {"::oo::InfoObject::variables", InfoObjectVariablesCmd},
{"::oo::InfoObject::vars", InfoObjectVarsCmd},
{NULL, NULL}
};
@@ -70,6 +73,7 @@ static const struct NameProcMap infoClassCmds[] = {
{"::oo::InfoClass::mixins", InfoClassMixinsCmd},
{"::oo::InfoClass::subclasses", InfoClassSubsCmd},
{"::oo::InfoClass::superclasses", InfoClassSupersCmd},
+ {"::oo::InfoClass::variables", InfoClassVariablesCmd},
{NULL, NULL}
};
@@ -268,18 +272,8 @@ InfoObjectDefnCmd(
}
}
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
-
- /*
- * This is copied from the [info body] implementation. See the comments
- * there for why this copy has to be done here.
- */
-
- if (procPtr->bodyPtr->bytes == NULL) {
- (void) Tcl_GetString(procPtr->bodyPtr);
- }
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(procPtr->bodyPtr->bytes,
- procPtr->bodyPtr->length));
+ TclOOGetMethodBody(Tcl_GetHashValue(hPtr)));
return TCL_OK;
}
@@ -617,6 +611,42 @@ InfoObjectMixinsCmd(
/*
* ----------------------------------------------------------------------
*
+ * InfoObjectVariablesCmd --
+ *
+ * Implements [info object variables $objName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectVariablesCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ Tcl_Obj *variableObj;
+ int i;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), variableObj);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* InfoObjectVarsCmd --
*
* Implements [info object vars $objName ?$pattern?]
@@ -739,12 +769,8 @@ InfoClassConstrCmd(
}
}
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
- if (procPtr->bodyPtr->bytes == NULL) {
- (void) Tcl_GetString(procPtr->bodyPtr);
- }
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(procPtr->bodyPtr->bytes,
- procPtr->bodyPtr->length));
+ TclOOGetMethodBody(clsPtr->constructorPtr));
return TCL_OK;
}
@@ -816,12 +842,8 @@ InfoClassDefnCmd(
}
}
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
- if (procPtr->bodyPtr->bytes == NULL) {
- (void) Tcl_GetString(procPtr->bodyPtr);
- }
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(procPtr->bodyPtr->bytes,
- procPtr->bodyPtr->length));
+ TclOOGetMethodBody(Tcl_GetHashValue(hPtr)));
return TCL_OK;
}
@@ -871,12 +893,7 @@ InfoClassDestrCmd(
return TCL_ERROR;
}
- if (procPtr->bodyPtr->bytes == NULL) {
- (void) Tcl_GetString(procPtr->bodyPtr);
- }
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(procPtr->bodyPtr->bytes,
- procPtr->bodyPtr->length));
+ Tcl_SetObjResult(interp, TclOOGetMethodBody(clsPtr->destructorPtr));
return TCL_OK;
}
@@ -1263,6 +1280,49 @@ InfoClassSupersCmd(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassVariablesCmd --
+ *
+ * Implements [info class variables $clsName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassVariablesCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ Class *clsPtr;
+ Tcl_Obj *variableObj;
+ int i;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+
+ FOREACH(variableObj, clsPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), variableObj);
+ }
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 056091d..dbd7df2 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOOInt.h,v 1.7 2008/08/23 18:53:11 msofer Exp $
+ * RCS: @(#) $Id: tclOOInt.h,v 1.8 2008/09/23 05:05:54 dkf Exp $
*/
#include <tclInt.h>
@@ -175,6 +175,7 @@ typedef struct Object {
Tcl_ObjectMapMethodNameProc mapMethodNameProc;
/* Function to allow remapping of method
* names. For itcl-ng. */
+ LIST_STATIC(Tcl_Obj *) variables;
} Object;
#define OBJECT_DELETED 1 /* Flag to say that an object has been
@@ -248,6 +249,7 @@ typedef struct Class {
* object doesn't override with its own mixins
* (and filters and method implementations for
* when getting method chains). */
+ LIST_STATIC(Tcl_Obj *) variables;
} Class;
/*
@@ -422,6 +424,9 @@ MODULE_SCOPE int TclOODefineSuperclassObjCmd(ClientData clientData,
MODULE_SCOPE int TclOODefineUnexportObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineVariablesObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
@@ -492,6 +497,7 @@ MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr);
MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr);
+MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr);
MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr,
int flags, const char ***stringsPtr);
MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, int flags,
@@ -514,6 +520,7 @@ MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr,
Class *superPtr);
MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr,
CallContext *contextPtr);
+MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
/*
* Include all the private API, generated from tclOO.decls.
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 5371719..dfd2d14 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOOMethod.c,v 1.18 2008/09/01 00:35:42 dkf Exp $
+ * RCS: @(#) $Id: tclOOMethod.c,v 1.19 2008/09/23 05:05:54 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -18,6 +18,12 @@
#include "tclOOInt.h"
#include "tclCompile.h"
+#if 0
+#define DBPRINT(format, ...) (fprintf(stderr, "DEBUG:" format "\n", __VA_ARGS__))
+#else
+#define DBPRINT(format, ...) ((void) 0)
+#endif
+
/*
* Structure used to help delay computing names of objects or classes for
* [info frame] until needed, making invokation faster in the normal case.
@@ -46,6 +52,20 @@ typedef struct {
} PMFrameData;
/*
+ * Structure used to pass information about variable resolution to the
+ * on-the-ground resolvers used when working with resolved compiled variables.
+ */
+
+typedef struct {
+ Tcl_ResolvedVarInfo info; /* "Type" information so that the compiled
+ * variable can be linked to the namespace
+ * variable at the right time. */
+ Tcl_Obj *variableObj; /* The name of the variable. */
+ Tcl_Var cachedObjectVar; /* TODO: When to flush this cache? Can class
+ * variables be cached? */
+} OOResVarInfo;
+
+/*
* Function declarations for things defined in this file.
*/
@@ -81,6 +101,13 @@ static int InvokeForwardMethod(ClientData clientData,
static void DeleteForwardMethod(ClientData clientData);
static int CloneForwardMethod(Tcl_Interp *interp,
ClientData clientData, ClientData *newClientData);
+static int ProcedureMethodVarResolver(Tcl_Interp *interp,
+ const char *varName, Tcl_Namespace *contextNs,
+ int flags, Tcl_Var *varPtr);
+static int ProcedureMethodCompiledVarResolver(Tcl_Interp *interp,
+ const char *varName, int length,
+ Tcl_Namespace *contextNs,
+ Tcl_ResolvedVarInfo **rPtrPtr);
/*
* The types of methods defined by the core OO system.
@@ -94,6 +121,15 @@ static const Tcl_MethodType fwdMethodType = {
TCL_OO_METHOD_VERSION_CURRENT, "forward",
InvokeForwardMethod, DeleteForwardMethod, CloneForwardMethod
};
+
+/*
+ * Helper macros (derived from things private to tclVar.c)
+ */
+
+#define TclVarTable(contextNs) \
+ ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable))
+#define TclVarHashGetValue(hPtr) \
+ ((Tcl_Var) ((char *)hPtr - TclOffset(VarInHash, entry)))
/*
* ----------------------------------------------------------------------
@@ -319,6 +355,7 @@ TclOONewProcInstanceMethod(
pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
pmPtr->flags = flags & USE_DECLARER_NS;
pmPtr->refCount = 1;
+
method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj,
argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
if (method == NULL) {
@@ -380,9 +417,8 @@ TclOONewProcMethod(
pmPtr->flags = flags & USE_DECLARER_NS;
pmPtr->refCount = 1;
- method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj,
- procName, argsObj, bodyObj, &procMethodType, pmPtr,
- &pmPtr->procPtr);
+ method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName,
+ argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
if (argsLen == -1) {
Tcl_DecrRefCount(argsObj);
@@ -866,6 +902,213 @@ PushMethodCallFrame(
/*
* ----------------------------------------------------------------------
*
+ * TclOOSetupVariableResolver, etc. --
+ *
+ * Variable resolution engine used to connect declared variables to local
+ * variables used in methods. The compiled variable resolver is more
+ * important, but both are needed as it is possible to have a variable
+ * that is only referred to in ways that aren't compilable and we can't
+ * force LVT presence. [TIP #320]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOSetupVariableResolver(
+ Tcl_Namespace *nsPtr)
+{
+ Tcl_ResolverInfo info;
+
+ Tcl_GetNamespaceResolvers(nsPtr, &info);
+ if (info.compiledVarResProc == NULL) {
+ Tcl_SetNamespaceResolvers(nsPtr, NULL, ProcedureMethodVarResolver,
+ ProcedureMethodCompiledVarResolver);
+ }
+}
+
+static int
+ProcedureMethodVarResolver(
+ Tcl_Interp *interp,
+ const char *varName,
+ Tcl_Namespace *contextNs,
+ int flags,
+ Tcl_Var *varPtr)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *framePtr = iPtr->varFramePtr;
+ CallContext *contextPtr;
+ Tcl_Obj *variableObj;
+ Tcl_HashEntry *hPtr;
+ int i, isNew;
+
+ /*
+ * Check that the variable is being requested in a context that is also a
+ * method call; if not (i.e. we're evaluating in the object's namespace or
+ * in a procedure of that namespace) then we do nothing.
+ */
+
+ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ return TCL_CONTINUE;
+ }
+ contextPtr = framePtr->clientData;
+
+ /*
+ * Check if the variable is one we want to resolve at all (i.e. whether it
+ * is in the list provided by the user). If not, we mustn't do anything
+ * either.
+ */
+
+ if (contextPtr->callPtr->chain[contextPtr->index]
+ .mPtr->declaringClassPtr != NULL) {
+ FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index]
+ .mPtr->declaringClassPtr->variables) {
+ if (!strcmp(Tcl_GetString(variableObj), varName)) {
+ goto gotMatch;
+ }
+ }
+ } else {
+ FOREACH(variableObj, contextPtr->oPtr->variables) {
+ if (!strcmp(Tcl_GetString(variableObj), varName)) {
+ goto gotMatch;
+ }
+ }
+ }
+ return TCL_CONTINUE;
+
+ /*
+ * It is a variable we want to resolve, so resolve it.
+ */
+
+ gotMatch:
+ hPtr = Tcl_CreateHashEntry(TclVarTable(contextNs), (char *) variableObj,
+ &isNew);
+ if (isNew) {
+ TclSetVarNamespaceVar((Var *) TclVarHashGetValue(hPtr));
+ }
+ *varPtr = TclVarHashGetValue(hPtr);
+ return TCL_OK;
+}
+
+static Tcl_Var
+ProcedureMethodCompiledVarConnect(
+ Tcl_Interp *interp,
+ Tcl_ResolvedVarInfo *rPtr)
+{
+ OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *framePtr = iPtr->varFramePtr;
+ CallContext *contextPtr;
+ Tcl_Obj *variableObj;
+ Tcl_HashEntry *hPtr;
+ int i, isNew, cacheIt;
+ const char *varName = Tcl_GetString(infoPtr->variableObj);
+
+ /*
+ * Check that the variable is being requested in a context that is also a
+ * method call; if not (i.e. we're evaluating in the object's namespace or
+ * in a procedure of that namespace) then we do nothing.
+ */
+
+ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ return NULL;
+ }
+ contextPtr = framePtr->clientData;
+
+ /*
+ * If we've done the work before (in a comparable context) then reuse that
+ * rather than performing resolution ourselves.
+ */
+
+ if (infoPtr->cachedObjectVar) {
+ return infoPtr->cachedObjectVar;
+ }
+
+ /*
+ * Check if the variable is one we want to resolve at all (i.e. whether it
+ * is in the list provided by the user). If not, we mustn't do anything
+ * either.
+ */
+
+ if (contextPtr->callPtr->chain[contextPtr->index]
+ .mPtr->declaringClassPtr != NULL) {
+ FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index]
+ .mPtr->declaringClassPtr->variables) {
+ if (!strcmp(Tcl_GetString(variableObj), varName)) {
+ cacheIt = 0;
+ goto gotMatch;
+ }
+ }
+ } else {
+ FOREACH(variableObj, contextPtr->oPtr->variables) {
+ if (!strcmp(Tcl_GetString(variableObj), varName)) {
+ cacheIt = 1;
+ goto gotMatch;
+ }
+ }
+ }
+ return NULL;
+
+ /*
+ * It is a variable we want to resolve, so resolve it.
+ */
+
+ gotMatch:
+ hPtr = Tcl_CreateHashEntry(TclVarTable(contextPtr->oPtr->namespacePtr),
+ (char *) variableObj, &isNew);
+ if (isNew) {
+ TclSetVarNamespaceVar((Var *) TclVarHashGetValue(hPtr));
+ }
+ if (cacheIt) {
+ infoPtr->cachedObjectVar = TclVarHashGetValue(hPtr);
+ }
+ return TclVarHashGetValue(hPtr);
+}
+
+static void
+ProcedureMethodCompiledVarDelete(
+ Tcl_ResolvedVarInfo *rPtr)
+{
+ OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
+
+ Tcl_DecrRefCount(infoPtr->variableObj);
+ ckfree((char *) infoPtr);
+}
+
+static int
+ProcedureMethodCompiledVarResolver(
+ Tcl_Interp *interp,
+ const char *varName,
+ int length,
+ Tcl_Namespace *contextNs,
+ Tcl_ResolvedVarInfo **rPtrPtr)
+{
+ OOResVarInfo *infoPtr;
+ Tcl_Obj *variableObj = Tcl_NewStringObj(varName, length);
+
+ /*
+ * Do not create resolvers for cases that contain namespace separators or
+ * which look like array accesses. Both will lead us astray.
+ */
+
+ if (strstr(Tcl_GetString(variableObj), "::") != NULL ||
+ Tcl_StringMatch(Tcl_GetString(variableObj), "*(*)")) {
+ Tcl_DecrRefCount(variableObj);
+ return TCL_CONTINUE;
+ }
+
+ infoPtr = (OOResVarInfo *) ckalloc(sizeof(OOResVarInfo));
+ infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect;
+ infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete;
+ infoPtr->cachedObjectVar = NULL;
+ infoPtr->variableObj = variableObj;
+ Tcl_IncrRefCount(variableObj);
+ *rPtrPtr = &infoPtr->info;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* RenderDeclarerName --
*
* Returns the name of the entity (object or class) which declared a
@@ -1244,6 +1487,21 @@ TclOOGetProcFromMethod(
}
Tcl_Obj *
+TclOOGetMethodBody(
+ Method *mPtr)
+{
+ if (mPtr->typePtr == &procMethodType) {
+ ProcedureMethod *pmPtr = mPtr->clientData;
+
+ if (pmPtr->procPtr->bodyPtr->bytes == NULL) {
+ (void) Tcl_GetString(pmPtr->procPtr->bodyPtr);
+ }
+ return pmPtr->procPtr->bodyPtr;
+ }
+ return NULL;
+}
+
+Tcl_Obj *
TclOOGetFwdFromMethod(
Method *mPtr)
{
diff --git a/tests/oo.test b/tests/oo.test
index 3575511..5b261f7 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -7,7 +7,7 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: oo.test,v 1.11 2008/08/20 15:41:26 dkf Exp $
+# RCS: @(#) $Id: oo.test,v 1.12 2008/09/23 05:05:54 dkf Exp $
package require TclOO 0.4 ;# Must match value in configure.in
if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -1123,7 +1123,7 @@ test oo-16.2 {OO: object introspection} -body {
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
test oo-16.3 {OO: object introspection} -body {
info object gorp oo::object
-} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be class, definition, filters, forward, isa, methods, mixins, or vars}
+} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be class, definition, filters, forward, isa, methods, mixins, variables, or vars}
test oo-16.4 {OO: object introspection} -setup {
oo::class create meta { superclass oo::class }
[meta create instance1] create instance2
@@ -1228,7 +1228,7 @@ test oo-17.3 {OO: class introspection} -setup {
} -result {"foo" is not a class}
test oo-17.4 {OO: class introspection} -body {
info class gorp oo::object
-} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, mixins, subclasses, or superclasses}
+} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, mixins, subclasses, superclasses, or variables}
test oo-17.5 {OO: class introspection} -setup {
oo::class create testClass
} -body {
@@ -1830,6 +1830,193 @@ test oo-26.3 {Bug 2037727} -setup {
example destroy
} -result {{} nonempty}
+test oo-26.1 {variables declaration - class introspection} -setup {
+ oo::class create foo
+} -cleanup {
+ foo destroy
+} -body {
+ oo::define foo variable a b c
+ info class variables foo
+} -result {a b c}
+test oo-26.2 {variables declaration - object introspection} -setup {
+ oo::object create foo
+} -cleanup {
+ foo destroy
+} -body {
+ oo::objdefine foo variable a b c
+ info object variables foo
+} -result {a b c}
+test oo-26.3 {variables declaration - basic behaviour} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x!
+ constructor {} {set x! 1}
+ method y {} {incr x!}
+ }
+ foo create bar
+ bar y
+ bar y
+} -result 3
+test oo-26.4 {variables declaration - destructors too} -setup {
+ oo::class create master
+ set result bad!
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x!
+ constructor {} {set x! 1}
+ method y {} {incr x!}
+ destructor {set ::result ${x!}}
+ }
+ foo create bar
+ bar y
+ bar y
+ bar destroy
+ return $result
+} -result 3
+test oo-26.5 {variables declaration - object-bound variables} -setup {
+ oo::object create foo
+} -cleanup {
+ foo destroy
+} -body {
+ oo::objdefine foo {
+ variable x!
+ method y {} {incr x!}
+ }
+ foo y
+ foo y
+} -result 2
+test oo-26.6 {variables declaration - non-interference of levels} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x!
+ constructor {} {set x! 1}
+ method y {} {incr x!}
+ }
+ foo create bar
+ oo::objdefine bar {
+ variable y!
+ method y {} {list [next] [incr y!] [info var] [info local]}
+ export eval
+ }
+ bar y
+ list [bar y] [lsort [info object vars bar]] [bar eval {info vars *!}]
+} -result {{3 2 y! {}} {x! y!} {x! y!}}
+test oo-26.7 {variables declaration - one underlying variable space} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x!
+ constructor {} {set x! 1}
+ method y {} {incr x!}
+ }
+ oo::class create foo2 {
+ superclass foo
+ variable y!
+ constructor {} {set y! 42; next}
+ method x {} {incr y! -1}
+ }
+ foo2 create bar
+ oo::objdefine bar {
+ variable x! y!
+ method z {} {list ${x!} ${y!}}
+ }
+ bar y
+ bar x
+ list [bar y] [bar x] [bar z]
+} -result {3 40 {3 40}}
+test oo-26.8 {variables declaration - error cases - ns separators} -body {
+ oo::define oo::object variable bad::var
+} -returnCodes error -result {invalid declared variable name "bad::var": must not contain namespace separators}
+test oo-26.9 {variables declaration - error cases - arrays} -body {
+ oo::define oo::object variable bad(var)
+} -returnCodes error -result {invalid declared variable name "bad(var)": must not refer to an array element}
+test oo-26.10 {variables declaration - no instance var leaks with class resolvers} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable clsvar
+ constructor {} {
+ set clsvar 0
+ }
+ method step {} {
+ incr clsvar
+ return
+ }
+ method value {} {
+ return $clsvar
+ }
+ }
+ foo create inst1
+ inst1 step
+ foo create inst2
+ inst2 step
+ inst1 step
+ inst2 step
+ inst1 step
+ list [inst1 value] [inst2 value]
+} -result {3 2}
+test oo-26.11 {variables declaration - no instance var leaks with class resolvers} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable clsvar
+ constructor {} {
+ set clsvar 0
+ }
+ method step {} {
+ incr clsvar
+ return
+ }
+ method value {} {
+ return $clsvar
+ }
+ }
+ foo create inst1
+ oo::objdefine inst1 {
+ variable clsvar
+ method reinit {} {
+ set clsvar 0
+ }
+ }
+ foo create inst2
+ oo::objdefine inst2 {
+ variable clsvar
+ method reinit {} {
+ set clsvar 0
+ }
+ }
+ inst1 step
+ inst2 step
+ inst1 reinit
+ inst2 reinit
+ inst1 step
+ inst2 step
+ inst1 step
+ inst2 step
+ inst1 step
+ list [inst1 value] [inst2 value]
+} -result {3 2}
+
cleanupTests
return
generated by cgit v0.12 at 2024-06-29 04:13:13 (GMT)