Itcl - the [incr Tcl] extension

Changes On Branch sebres-memopt-perf-branch
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Changes In Branch sebres-memopt-perf-branch Excluding Merge-Ins

This is equivalent to a diff from 783c4c0d18 to 348d9767d3

2019-10-02
17:53
(Re-)implement a public set of routines for allocation and interest management of memory blocks shared by independent modules. These routines do not suffer the performance scaling failures of their Tcl counterparts, which is important to Itcl's usage patterns. Bump the version number to account for new public routines. Thanks to sebres for the contribution. check-in: 3559fa204b user: dgp tags: trunk
17:46
Bump to version Itcl 4.2.0 to account for additions to set of public routines. Closed-Leaf check-in: 348d9767d3 user: dgp tags: sebres-memopt-perf-branch
17:38
Document new (and old!) public routines. check-in: a03aaa0379 user: dgp tags: sebres-memopt-perf-branch
2019-09-20
16:34
merge trunk check-in: db7140f46e user: dgp tags: sebres-memopt-perf-branch
2019-09-19
13:54
Don't bother compiling with /DUNICODE /D_UNICODE, since Itcl doesn't use any Unicode Win32 API check-in: 783c4c0d18 user: jan.nijtmans tags: trunk
2019-09-18
12:46
Use [::tcl::pkgconfig get debug] to check for debug mode, this is the only way that can be thrusted on all platforms. Update rules.vc to latest version check-in: 5e920169a8 user: jan.nijtmans tags: trunk

Changes to configure.
1
2
3

4
5
6
7
8
9
10
1
2

3
4
5
6
7
8
9
10


-
+







#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.69 for itcl 4.1.2.
# Generated by GNU Autoconf 2.69 for itcl 4.2.0.
#
#
# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc.
#
#
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
573
574
575
576
577
578
579
580
581


582
583
584
585
586
587
588
573
574
575
576
577
578
579


580
581
582
583
584
585
586
587
588







-
-
+
+







subdirs=
MFLAGS=
MAKEFLAGS=

# Identity of this package.
PACKAGE_NAME='itcl'
PACKAGE_TARNAME='itcl'
PACKAGE_VERSION='4.1.2'
PACKAGE_STRING='itcl 4.1.2'
PACKAGE_VERSION='4.2.0'
PACKAGE_STRING='itcl 4.2.0'
PACKAGE_BUGREPORT=''
PACKAGE_URL=''

# Factoring default headers for most tests.
ac_includes_default="\
#include <stdio.h>
#ifdef HAVE_SYS_TYPES_H
1301
1302
1303
1304
1305
1306
1307
1308

1309
1310
1311
1312
1313
1314
1315
1301
1302
1303
1304
1305
1306
1307

1308
1309
1310
1311
1312
1313
1314
1315







-
+







#
# Report the --help message.
#
if test "$ac_init_help" = "long"; then
  # Omit some internal or obsolete options to make the list less imposing.
  # This message is too long to be a string in the A/UX 3.1 sh.
  cat <<_ACEOF
\`configure' configures itcl 4.1.2 to adapt to many kinds of systems.
\`configure' configures itcl 4.2.0 to adapt to many kinds of systems.

Usage: $0 [OPTION]... [VAR=VALUE]...

To assign environment variables (e.g., CC, CFLAGS...), specify them as
VAR=VALUE.  See below for descriptions of some of the useful variables.

Defaults for the options are specified in brackets.
1362
1363
1364
1365
1366
1367
1368
1369

1370
1371
1372
1373
1374
1375
1376
1362
1363
1364
1365
1366
1367
1368

1369
1370
1371
1372
1373
1374
1375
1376







-
+








  cat <<\_ACEOF
_ACEOF
fi

if test -n "$ac_init_help"; then
  case $ac_init_help in
     short | recursive ) echo "Configuration of itcl 4.1.2:";;
     short | recursive ) echo "Configuration of itcl 4.2.0:";;
   esac
  cat <<\_ACEOF

Optional Features:
  --disable-option-checking  ignore unrecognized --enable/--with options
  --disable-FEATURE       do not include FEATURE (same as --enable-FEATURE=no)
  --enable-FEATURE[=ARG]  include FEATURE [ARG=yes]
1462
1463
1464
1465
1466
1467
1468
1469

1470
1471
1472
1473
1474
1475
1476
1462
1463
1464
1465
1466
1467
1468

1469
1470
1471
1472
1473
1474
1475
1476







-
+







    cd "$ac_pwd" || { ac_status=$?; break; }
  done
fi

test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
  cat <<\_ACEOF
itcl configure 4.1.2
itcl configure 4.2.0
generated by GNU Autoconf 2.69

Copyright (C) 2012 Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
  exit
1794
1795
1796
1797
1798
1799
1800
1801

1802
1803
1804
1805
1806
1807
1808
1794
1795
1796
1797
1798
1799
1800

1801
1802
1803
1804
1805
1806
1807
1808







-
+







  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno

} # ac_fn_c_check_type
cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by itcl $as_me 4.1.2, which was
It was created by itcl $as_me 4.2.0, which was
generated by GNU Autoconf 2.69.  Invocation command line was

  $ $0 $@

_ACEOF
exec 5>>config.log
{
8826
8827
8828
8829
8830
8831
8832
8833

8834
8835
8836
8837
8838
8839
8840
8826
8827
8828
8829
8830
8831
8832

8833
8834
8835
8836
8837
8838
8839
8840







-
+







test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1

cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
# Save the log message, to keep $0 and so on meaningful, and to
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
This file was extended by itcl $as_me 4.1.2, which was
This file was extended by itcl $as_me 4.2.0, which was
generated by GNU Autoconf 2.69.  Invocation command line was

  CONFIG_FILES    = $CONFIG_FILES
  CONFIG_HEADERS  = $CONFIG_HEADERS
  CONFIG_LINKS    = $CONFIG_LINKS
  CONFIG_COMMANDS = $CONFIG_COMMANDS
  $ $0 $@
8879
8880
8881
8882
8883
8884
8885
8886

8887
8888
8889
8890
8891
8892
8893
8879
8880
8881
8882
8883
8884
8885

8886
8887
8888
8889
8890
8891
8892
8893







-
+








Report bugs to the package provider."

_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
itcl config.status 4.1.2
itcl config.status 4.2.0
configured by $0, generated by GNU Autoconf 2.69,
  with options \\"\$ac_cs_config\\"

Copyright (C) 2012 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."

Changes to configure.ac.
15
16
17
18
19
20
21
22

23
24
25
26
27
28
29
15
16
17
18
19
20
21

22
23
24
25
26
27
28
29







-
+







# This initializes the environment with PACKAGE_NAME and PACKAGE_VERSION
# set as provided.  These will also be added as -D defs in your Makefile
# so you can encode the package version directly into the source files.
# This will also define a special symbol for Windows (BUILD_<PACKAGE_NAME>
# so that we create the export library with the dll.
#-----------------------------------------------------------------------

AC_INIT([itcl], [4.1.2])
AC_INIT([itcl], [4.2.0])

#--------------------------------------------------------------------
# Call TEA_INIT as the first TEA_ macro to set up initial vars.
# This will define a ${TEA_PLATFORM} variable == "unix" or "windows"
# as well as PKG_LIB_FILE and PKG_STUB_LIB_FILE.
#--------------------------------------------------------------------

Changes to doc/Preserve.3.
1
2
3
4
5
6
7
8
9
10
11
12

13
14
15
16



17
18

19
20
21

22
23
24




25
26




27
28
29
30
31
32
33
34




































35
36
37
38
1
2
3
4
5
6
7
8
9
10
11

12
13
14
15
16
17
18
19
20

21
22
23

24
25
26

27
28
29
30
31
32
33
34
35
36
37
38


39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82











-
+




+
+
+

-
+


-
+


-
+
+
+
+


+
+
+
+


-
-




+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+




'\"
'\" Copyright (c) 1993-1998  Lucent Technologies, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH Itcl_PreserveData 3 3.0 itcl "[incr\ Tcl] Library Procedures"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Itcl_PreserveData, Itcl_ReleaseData, Itcl_EventuallyFree \- Manipulate an Itcl list object.
Itcl_Alloc, Itcl_Free, Itcl_PreserveData, Itcl_ReleaseData, Itcl_EventuallyFree \- Manipulate an Itcl list object.
.SH SYNOPSIS
.nf
\fB#include <itcl.h>\fR

void *
\fBItcl_Alloc\fR(\fIsize\fR)

void
\fBItcl_PreserveData\fR(\fIcdata\fR)
\fBItcl_PreserveData\fR(\fIptr\fR)

void
\fBItcl_ReleaseData\fR(\fIcdata\fR)
\fBItcl_ReleaseData\fR(\fIptr\fR)

void
\fBItcl_EventuallyFree\fR(\fIcdata, fproc\fR)
\fBItcl_EventuallyFree\fR(\fIptr, fproc\fR)

void
\fBItcl_Free\fR(\fIptr\fR)
.fi
.SH ARGUMENTS
.AP size_t size in
Number of bytes to allocate.
.AP void *ptr in
Pointer value allocated by \fBItcl_Alloc\fR.
.AP Tcl_FreeProc *fproc in
Address of function to call when the block is to be freed.
.AP ClientData clientData in
Arbitrary one-word value.
.BE

.SH DESCRIPTION
.PP
These procedures are used to allocate and release memory, especially blocks
of memory that will be used by multiple independent modules. They are similar
in function to the routines in the public Tcl interface, \fBTcl_Alloc\fR,
\fBTcl_Free\fR, \fBTcl_Preserve\fR, \fBTcl_Release\fR, and
\fBTcl_EventuallyFree\fR. The Tcl routines suffer from issues with
performance scaling as the number of blocks managed grows large. The facilities
of Itcl encounter these performance scaling issues and require an
alternative that does not suffer from them.
.PP
\fBItcl_Alloc\fR returns an untyped pointer to an allocated block
of memory of at least \fIsize\fR bytes.
.PP
A module calls \fBItcl_PreserveData\fR on a pointer \fIptr\fR 
allocated by \fBItcl_Alloc\fR to prevent deallocation of that memory while
the module remains interested in it.
.PP
A module calls \fBItcl_ReleaseData\fR on a pointer \fIptr\fR previously
preserved by \fBItcl_PreserveData\fR to indicate the module no longer has
an interest in the block of memory, and will not be disturbed by its
deallocation.
.PP
\fBItcl_EventuallyFree\fR is called on a pointer \fIptr\fR allocated by
\fBItcl_Alloc\fR to register a deallocation routine \fIfproc\fR to be
called when the number of calls to \fBItcl_ReleaseData\fR on \fIptr\fR
matches the number of calls to \fBItcl_PreserveData\fR on \fIptr\fR. This
condition indicates all modules have ended their interest in the block
of memory and a call to \fIfproc\ with argument \fIptr\fR will deallocate
the memory that no module needs anymore.
.PP
\fBItcl_Free\fR is a deallocation routine for a \fIptr\fR value allocated
by \fBItcl_Alloc\fR. It may be called on any \fIptr\fR with no history of
an \fBItcl_PreserveData\fR call unmatched by an \fBItcl_ReleaseData\fR
call. It is best used as an \fIfproc\fR argument to \fBItcl_EventuallyFree\fR
or as a routine called from within such an \fIfproc\fR routine. It can also
be used to deallocate a \fIptr\fR value when it can be assured that value
has never been passed to \fBItcl_PreserveData\fR or \fBItcl_EventuallyFree\fR.

.SH KEYWORDS
free, memory

Changes to generic/itcl.decls.
85
86
87
88
89
90
91






92
93
94
95
96
97
98
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104







+
+
+
+
+
+







}
declare 24 {
    int Itcl_RestoreInterpState(Tcl_Interp *interp, Itcl_InterpState state)
}
declare 25 {
    void Itcl_DiscardInterpState(Itcl_InterpState state)
}
declare 26 {
    void * Itcl_Alloc(size_t size)
}
declare 27 {
    void Itcl_Free(void *ptr)
}


# private API
interface itclInt
#
# Functions used within the package, but not considered "public"
#
Changes to generic/itcl.h.
76
77
78
79
80
81
82
83

84
85

86
87
88


89
90
91
92
93
94
95
76
77
78
79
80
81
82

83
84

85
86


87
88
89
90
91
92
93
94
95







-
+

-
+

-
-
+
+







#   define TCL_BETA_RELEASE     1
#endif
#ifndef TCL_FINAL_RELEASE
#   define TCL_FINAL_RELEASE    2
#endif

#define ITCL_MAJOR_VERSION	4
#define ITCL_MINOR_VERSION	1
#define ITCL_MINOR_VERSION	2
#define ITCL_RELEASE_LEVEL      TCL_FINAL_RELEASE
#define ITCL_RELEASE_SERIAL     2
#define ITCL_RELEASE_SERIAL     0

#define ITCL_VERSION            "4.1"
#define ITCL_PATCH_LEVEL        "4.1.2"
#define ITCL_VERSION            "4.2"
#define ITCL_PATCH_LEVEL        "4.2.0"


/*
 * A special definition used to allow this header file to be included from
 * windows resource files so that they can obtain version information.
 * RC_INVOKED is defined by default by the windows RC tool.
 *
Changes to generic/itclBase.c.
190
191
192
193
194
195
196
197

198
199
200
201

202
203
204
205
206
207
208

209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
190
191
192
193
194
195
196

197
198
199
200

201
202
203
204
205
206
207

208
209
210
211
212
213
214
215
216
217

218
219
220
221
222
223
224







-
+



-
+






-
+









-







    clazzObjectPtr = Tcl_GetObjectFromObj(interp, objPtr);
    if (!clazzObjectPtr || !(tclCls = Tcl_GetObjectAsClass(clazzObjectPtr))) {
	Tcl_DecrRefCount(objPtr);
        return TCL_ERROR;
    }
    Tcl_DecrRefCount(objPtr);

    infoPtr = (ItclObjectInfo*)ckalloc(sizeof(ItclObjectInfo));
    infoPtr = (ItclObjectInfo*)Itcl_Alloc(sizeof(ItclObjectInfo));

    nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE, infoPtr, FreeItclObjectInfo);
    if (nsPtr == NULL) {
	ckfree(infoPtr);
	Itcl_Free(infoPtr);
        Tcl_Panic("Itcl: cannot create namespace: \"%s\" \n", ITCL_NAMESPACE);
    }

    nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE"::internal::dicts",
            NULL, NULL);
    if (nsPtr == NULL) {
	ckfree(infoPtr);
	Itcl_Free(infoPtr);
        Tcl_Panic("Itcl: cannot create namespace: \"%s::internal::dicts\" \n",
	        ITCL_NAMESPACE);
    }

    /*
     *  Create the top-level data structure for tracking objects.
     *  Store this as "associated data" for easy access, but link
     *  it to the itcl namespace for ownership.
     */
    memset(infoPtr, 0, sizeof(ItclObjectInfo));
    infoPtr->interp = interp;
    infoPtr->class_meta_type = (Tcl_ObjectMetadataType *)ckalloc(
            sizeof(Tcl_ObjectMetadataType));
    infoPtr->class_meta_type->version = TCL_OO_METADATA_VERSION_CURRENT;
    infoPtr->class_meta_type->name = "ItclClass";
    infoPtr->class_meta_type->deleteProc = ItclDeleteClassMetadata;
    infoPtr->class_meta_type->cloneProc = NULL;
Changes to generic/itclClass.c.
289
290
291
292
293
294
295
296

297
298
299
300
301
302
303
289
290
291
292
293
294
295

296
297
298
299
300
301
302
303







-
+







    Tcl_InitHashTable(&iclsPtr->resolveVars, TCL_ONE_WORD_KEYS);
    Tcl_InitHashTable(&iclsPtr->contextCache, TCL_ONE_WORD_KEYS);

    Itcl_InitList(&iclsPtr->bases);
    Itcl_InitList(&iclsPtr->derived);

    resolveInfoPtr = (ItclResolveInfo *) ckalloc(sizeof(ItclResolveInfo));
    memset (resolveInfoPtr, 0, sizeof(ItclResolveInfo));
    memset(resolveInfoPtr, 0, sizeof(ItclResolveInfo));
    resolveInfoPtr->flags = ITCL_RESOLVE_CLASS;
    resolveInfoPtr->iclsPtr = iclsPtr;
    iclsPtr->resolvePtr = (Tcl_Resolve *)ckalloc(sizeof(Tcl_Resolve));
    iclsPtr->resolvePtr->cmdProcPtr = Itcl_CmdAliasProc;
    iclsPtr->resolvePtr->varProcPtr = Itcl_VarAliasProc;
    iclsPtr->resolvePtr->clientData = resolveInfoPtr;
    iclsPtr->flags    = infoPtr->currClassFlags;
900
901
902
903
904
905
906
907

908
909
910

911
912
913
914
915
916
917
900
901
902
903
904
905
906

907
908
909

910
911
912
913
914
915
916
917







-
+


-
+







     */
    hPtr = Tcl_FirstHashEntry(&iclsPtr->infoPtr->objects, &place);
    while (hPtr) {
        ioPtr = (ItclObject*)Tcl_GetHashValue(hPtr);
        if (ioPtr->iclsPtr == iclsPtr) {
	    if ((ioPtr->accessCmd != NULL) && (!(ioPtr->flags &
	            (ITCL_OBJECT_IS_DESTRUCTED)))) {
		ItclPreserveObject(ioPtr);
		Itcl_PreserveData(ioPtr);
                Tcl_DeleteCommandFromToken(iclsPtr->interp, ioPtr->accessCmd);
	        ioPtr->accessCmd = NULL;
		ItclReleaseObject(ioPtr);
		Itcl_ReleaseData(ioPtr);
	        /*
	         * Fix 227804: Whenever an object to delete was found we
	         * have to reset the search to the beginning as the
	         * current entry in the search was deleted and accessing it
	         * is therefore not allowed anymore.
	         */

1074
1075
1076
1077
1078
1079
1080
1081

1082
1083
1084
1085
1086
1087
1088
1074
1075
1076
1077
1078
1079
1080

1081
1082
1083
1084
1085
1086
1087
1088







-
+







    Tcl_DeleteHashTable(&iclsPtr->options);

    /*
     *  Delete all function definitions.
     */
    FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) {
	imPtr->iclsPtr = NULL;
        ItclReleaseIMF(imPtr);
        Itcl_ReleaseData(imPtr);
    }
    Tcl_DeleteHashTable(&iclsPtr->functions);

    /*
     *  Delete all delegated options.
     */
    FOREACH_HASH_VALUE(idoPtr, &iclsPtr->delegatedOptions) {
1209
1210
1211
1212
1213
1214
1215
1216

1217
1218
1219
1220
1221
1222
1223
1209
1210
1211
1212
1213
1214
1215

1216
1217
1218
1219
1220
1221
1222
1223







-
+







    Tcl_DecrRefCount(iclsPtr->namePtr);
    Tcl_DecrRefCount(iclsPtr->fullNamePtr);

    if (iclsPtr->resolvePtr != NULL) {
        ckfree((char *)iclsPtr->resolvePtr->clientData);
        ckfree((char *)iclsPtr->resolvePtr);
    }
    ckfree((char*)iclsPtr);
    ckfree(iclsPtr);
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_IsClassNamespace()
 *
1954
1955
1956
1957
1958
1959
1960
1961

1962
1963
1964
1965
1966
1967
1968
1969
1970
1971

1972
1973
1974
1975
1976
1977
1978
1954
1955
1956
1957
1958
1959
1960

1961
1962
1963
1964
1965
1966
1967
1968
1969


1970
1971
1972
1973
1974
1975
1976
1977







-
+








-
-
+







     */
    if (config) {
        if (Itcl_CreateMemberCode(interp, iclsPtr, NULL, config,
                &mCodePtr) != TCL_OK) {
            Tcl_DeleteHashEntry(hPtr);
            return TCL_ERROR;
        }
	ItclPreserveMemberCode(mCodePtr);
	Itcl_PreserveData(mCodePtr);
    } else {
        mCodePtr = NULL;
    }


    /*
     *  If everything looks good, create the variable definition.
     */
    ivPtr = (ItclVariable*)ckalloc(sizeof(ItclVariable));
    memset(ivPtr, 0, sizeof(ItclVariable));
    ivPtr = (ItclVariable*)Itcl_Alloc(sizeof(ItclVariable));
    ivPtr->iclsPtr      = iclsPtr;
    ivPtr->infoPtr      = iclsPtr->infoPtr;
    ivPtr->protection   = Itcl_Protection(interp, 0);
    ivPtr->codePtr      = mCodePtr;
    ivPtr->namePtr      = namePtr;
    Tcl_IncrRefCount(ivPtr->namePtr);
    ivPtr->fullNamePtr = Tcl_NewStringObj(
2325
2326
2327
2328
2329
2330
2331
2332

2333
2334
2335
2336
2337
2338
2339
2340
2341
2342

2343
2344
2345
2346
2347
2348
2349
2324
2325
2326
2327
2328
2329
2330

2331
2332
2333
2334
2335
2336
2337
2338
2339
2340

2341
2342
2343
2344
2345
2346
2347
2348







-
+









-
+







        hPtr = Tcl_FindHashEntry(&ivPtr->iclsPtr->variables,
                (char *)ivPtr->namePtr);
        if (hPtr != NULL) {
            Tcl_DeleteHashEntry(hPtr);
        }
    }
    if (ivPtr->codePtr != NULL) {
	ItclReleaseMemberCode(ivPtr->codePtr);
	Itcl_ReleaseData(ivPtr->codePtr);
    }
    Tcl_DecrRefCount(ivPtr->namePtr);
    Tcl_DecrRefCount(ivPtr->fullNamePtr);
    if (ivPtr->init) {
        Tcl_DecrRefCount(ivPtr->init);
    }
    if (ivPtr->arrayInitPtr) {
        Tcl_DecrRefCount(ivPtr->arrayInitPtr);
    }
    ckfree((char*)ivPtr);
    Itcl_Free(ivPtr);
}

/*
 * ------------------------------------------------------------------------
 *  ItclDeleteOption()
 *
 *  Destroys a option definition created by Itcl_CreateOption(),
2363
2364
2365
2366
2367
2368
2369
2370

2371
2372
2373
2374
2375
2376
2377
2362
2363
2364
2365
2366
2367
2368

2369
2370
2371
2372
2373
2374
2375
2376







-
+







        Tcl_DecrRefCount(ioptPtr->resourceNamePtr);
    }
    if (ioptPtr->resourceNamePtr != NULL) {
        Tcl_DecrRefCount(ioptPtr->classNamePtr);
    }

    if (ioptPtr->codePtr) {
	ItclReleaseMemberCode(ioptPtr->codePtr);
	Itcl_ReleaseData(ioptPtr->codePtr);
    }
    if (ioptPtr->defaultValuePtr != NULL) {
        Tcl_DecrRefCount(ioptPtr->defaultValuePtr);
    }
    if (ioptPtr->cgetMethodPtr != NULL) {
        Tcl_DecrRefCount(ioptPtr->cgetMethodPtr);
    }
2387
2388
2389
2390
2391
2392
2393
2394

2395
2396
2397
2398
2399
2400
2401
2386
2387
2388
2389
2390
2391
2392

2393
2394
2395
2396
2397
2398
2399
2400







-
+







    if (ioptPtr->validateMethodPtr != NULL) {
        Tcl_DecrRefCount(ioptPtr->validateMethodPtr);
    }
    if (ioptPtr->validateMethodVarPtr != NULL) {
        Tcl_DecrRefCount(ioptPtr->validateMethodVarPtr);
    }
    Itcl_ReleaseData(ioptPtr->idoPtr);
    ckfree((char*)ioptPtr);
    Itcl_Free(ioptPtr);
}

/*
 * ------------------------------------------------------------------------
 *  ItclDeleteFunction()
 *
 *  fre data associated with a function
2418
2419
2420
2421
2422
2423
2424
2425

2426
2427
2428
2429
2430
2431
2432
2417
2418
2419
2420
2421
2422
2423

2424
2425
2426
2427
2428
2429
2430
2431







-
+







        hPtr = Tcl_FindHashEntry(&imPtr->iclsPtr->functions,
                (char *)imPtr->namePtr);
        if (hPtr != NULL) {
            Tcl_DeleteHashEntry(hPtr);
        }
    }
    if (imPtr->codePtr != NULL) {
        ItclReleaseMemberCode(imPtr->codePtr);
        Itcl_ReleaseData(imPtr->codePtr);
    }
    Tcl_DecrRefCount(imPtr->namePtr);
    Tcl_DecrRefCount(imPtr->fullNamePtr);
    if (imPtr->usagePtr != NULL) {
        Tcl_DecrRefCount(imPtr->usagePtr);
    }
    if (imPtr->argumentPtr != NULL) {
2440
2441
2442
2443
2444
2445
2446
2447

2448
2449
2450
2451
2452
2453
2454
2439
2440
2441
2442
2443
2444
2445

2446
2447
2448
2449
2450
2451
2452
2453







-
+







    }
    if (imPtr->bodyPtr != NULL) {
        Tcl_DecrRefCount(imPtr->bodyPtr);
    }
    if (imPtr->argListPtr != NULL) {
        ItclDeleteArgList(imPtr->argListPtr);
    }
    ckfree((char*)imPtr);
    Itcl_Free(imPtr);
}

/*
 * ------------------------------------------------------------------------
 *  ItclDeleteComponent()
 *
 *  free data associated with a component
2501
2502
2503
2504
2505
2506
2507
2508

2509
2510
2511
2512
2513
2514
2515
2500
2501
2502
2503
2504
2505
2506

2507
2508
2509
2510
2511
2512
2513
2514







-
+







    }
    FOREACH_HASH_VALUE(objPtr, &idoPtr->exceptions) {
	if (objPtr != NULL) {
            Tcl_DecrRefCount(objPtr);
        }
    }
    Tcl_DeleteHashTable(&idoPtr->exceptions);
    ckfree((char *)idoPtr);
    Itcl_Free(idoPtr);
}

/*
 * ------------------------------------------------------------------------
 *  ItclDeleteDelegatedFunction()
 *
 *  free data associated with a delegated function
Changes to generic/itclDecls.h.
15
16
17
18
19
20
21
22

23
24
25
26
27
28
29
15
16
17
18
19
20
21

22
23
24
25
26
27
28
29







-
+








#endif


/* !BEGIN!: Do not edit below this line. */

#define ITCL_STUBS_EPOCH 0
#define ITCL_STUBS_REVISION 150
#define ITCL_STUBS_REVISION 152

#ifdef __cplusplus
extern "C" {
#endif

/*
 * Exported function declarations:
88
89
90
91
92
93
94




95
96
97
98
99
100
101
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105







+
+
+
+







/* 23 */
ITCLAPI Itcl_InterpState Itcl_SaveInterpState(Tcl_Interp *interp, int status);
/* 24 */
ITCLAPI int		Itcl_RestoreInterpState(Tcl_Interp *interp,
				Itcl_InterpState state);
/* 25 */
ITCLAPI void		Itcl_DiscardInterpState(Itcl_InterpState state);
/* 26 */
ITCLAPI void *		Itcl_Alloc(size_t size);
/* 27 */
ITCLAPI void		Itcl_Free(void *ptr);

typedef struct {
    const struct ItclIntStubs *itclIntStubs;
} ItclStubHooks;

typedef struct ItclStubs {
    int magic;
125
126
127
128
129
130
131


132
133
134
135
136
137
138
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144







+
+







    void (*itcl_SetListValue) (Itcl_ListElem *elemPtr, ClientData val); /* 19 */
    void (*itcl_EventuallyFree) (ClientData cdata, Tcl_FreeProc *fproc); /* 20 */
    void (*itcl_PreserveData) (ClientData cdata); /* 21 */
    void (*itcl_ReleaseData) (ClientData cdata); /* 22 */
    Itcl_InterpState (*itcl_SaveInterpState) (Tcl_Interp *interp, int status); /* 23 */
    int (*itcl_RestoreInterpState) (Tcl_Interp *interp, Itcl_InterpState state); /* 24 */
    void (*itcl_DiscardInterpState) (Itcl_InterpState state); /* 25 */
    void * (*itcl_Alloc) (size_t size); /* 26 */
    void (*itcl_Free) (void *ptr); /* 27 */
} ItclStubs;

extern const ItclStubs *itclStubsPtr;

#ifdef __cplusplus
}
#endif
189
190
191
192
193
194
195




196
197
198
199
200
201
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211







+
+
+
+






	(itclStubsPtr->itcl_ReleaseData) /* 22 */
#define Itcl_SaveInterpState \
	(itclStubsPtr->itcl_SaveInterpState) /* 23 */
#define Itcl_RestoreInterpState \
	(itclStubsPtr->itcl_RestoreInterpState) /* 24 */
#define Itcl_DiscardInterpState \
	(itclStubsPtr->itcl_DiscardInterpState) /* 25 */
#define Itcl_Alloc \
	(itclStubsPtr->itcl_Alloc) /* 26 */
#define Itcl_Free \
	(itclStubsPtr->itcl_Free) /* 27 */

#endif /* defined(USE_ITCL_STUBS) */

/* !END!: Do not edit above this line. */

#endif /* _ITCLDECLS */
Changes to generic/itclInt.h.
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
370
371
372
373
374
375
376

377
378
379
380
381
382
383







-







    Tcl_Obj *hullWindowNamePtr;   /* the window path name for the hull
                                   * (before renaming in installhull) */
    int destructorHasBeenCalled;  /* is set when the destructor is called
                                   * to avoid callin destructor twice */
    int noComponentTrace;         /* don't call component traces if
                                   * setting components in DelegationInstall */
    int hadConstructorError;      /* needed for multiple calls of CallItclObjectCmd */
    int refCount;
} ItclObject;

#define ITCL_IGNORE_ERRS  0x002  /* useful for construction/destruction */

typedef struct ItclResolveInfo {
    int flags;
    ItclClass *iclsPtr;
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
399
400
401
402
403
404
405

406
407
408
409
410
411
412







-







    Tcl_Obj *bodyPtr;           /* the function body */
    ItclArgList *argListPtr;    /* the parsed arguments */
    union {
        Tcl_CmdProc *argCmd;    /* (argc,argv) C implementation */
        Tcl_ObjCmdProc *objCmd; /* (objc,objv) C implementation */
    } cfunc;
    ClientData clientData;      /* client data for C implementations */
    int refCount;
} ItclMemberCode;

/*
 *  Flag bits for ItclMemberCode:
 */
#define ITCL_IMPLEMENT_NONE    0x001  /* no implementation */
#define ITCL_IMPLEMENT_TCL     0x002  /* Tcl implementation */
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
500
501
502
503
504
505
506

507
508
509
510
511
512
513







-







    Tcl_Obj *origArgsPtr;       /* the argument string of the original definition */
    Tcl_Obj *bodyPtr;           /* the function body */
    ItclArgList *argListPtr;    /* the parsed arguments */
    ItclClass *declaringClassPtr; /* the class which declared the method/proc */
    ClientData tmPtr;           /* TclOO methodPtr */
    ItclDelegatedFunction *idmPtr;
                                /* if the function is delegated != NULL */
    int refCount;
} ItclMemberFunc;

/*
 *  Instance variables.
 */
typedef struct ItclVariable {
    Tcl_Obj *namePtr;           /* member name */
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
656
657
658
659
660
661
662



663
664
665






666
667
668
669
670
671
672







-
-
-



-
-
-
-
-
-







#endif

MODULE_SCOPE Tcl_ObjCmdProc ItclCallCCommand;
MODULE_SCOPE Tcl_ObjCmdProc ItclObjectUnknownCommand;
MODULE_SCOPE int ItclCheckCallProc(ClientData clientData, Tcl_Interp *interp,
        Tcl_ObjectContext contextPtr, Tcl_CallFrame *framePtr, int *isFinished);

MODULE_SCOPE void ItclPreserveIMF(ItclMemberFunc *imPtr);
MODULE_SCOPE void ItclReleaseIMF(ClientData imPtr);

MODULE_SCOPE void ItclPreserveClass(ItclClass *iclsPtr);
MODULE_SCOPE void ItclReleaseClass(ClientData iclsPtr);

MODULE_SCOPE void ItclPreserveMemberCode(ItclMemberCode *mcodePtr);
MODULE_SCOPE void ItclReleaseMemberCode(ItclMemberCode *mcodePtr);

MODULE_SCOPE void ItclPreserveObject(ItclObject *ioPtr);
MODULE_SCOPE void ItclReleaseObject(ClientData ioPtr);

MODULE_SCOPE ItclFoundation *ItclGetFoundation(Tcl_Interp *interp);
MODULE_SCOPE Tcl_ObjCmdProc ItclClassCommandDispatcher;
MODULE_SCOPE Tcl_Command Itcl_CmdAliasProc(Tcl_Interp *interp,
        Tcl_Namespace *nsPtr, const char *cmdName, ClientData clientData);
MODULE_SCOPE Tcl_Var Itcl_VarAliasProc(Tcl_Interp *interp,
        Tcl_Namespace *nsPtr, const char *VarName, ClientData clientData);
MODULE_SCOPE int ItclIsClass(Tcl_Interp *interp, Tcl_Command cmd);
Changes to generic/itclIntDecls.h.
1
2
3
4
5
6
7
8
9
10
11

12
13
14
15
16
17
18
1
2
3
4
5
6
7
8
9
10

11
12
13
14
15
16
17
18










-
+







/*
 * This file is (mostly) automatically generated from itcl.decls.
 */

#ifndef _ITCLINTDECLS
#define _ITCLINTDECLS

/* !BEGIN!: Do not edit below this line. */

#define ITCLINT_STUBS_EPOCH 0
#define ITCLINT_STUBS_REVISION 150
#define ITCLINT_STUBS_REVISION 152

#ifdef __cplusplus
extern "C" {
#endif

/*
 * Exported function declarations:
Changes to generic/itclMethod.c.
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66


67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
36
37
38
39
40
41
42
























43
44












45
46
47
48
49
50
51







-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-







        ItclArgList *realArgs);
static int ItclCreateMemberCode(Tcl_Interp* interp, ItclClass *iclsPtr,
        const char* arglist, const char* body, ItclMemberCode** mcodePtr,
        Tcl_Obj *namePtr, int flags);
static int ItclCreateMemberFunc(Tcl_Interp* interp, ItclClass *iclsPtr,
	Tcl_Obj *namePtr, const char* arglist, const char* body,
        ItclMemberFunc** imPtrPtr, int flags);
void    ItclFreeMemberCode (ItclMemberCode *mcodePtr);

void
ItclPreserveIMF(
    ItclMemberFunc *imPtr)
{
    imPtr->refCount++;
}

void
ItclReleaseIMF(
    ClientData clientData)
{
    ItclMemberFunc *imPtr = (ItclMemberFunc *)clientData;

    if (imPtr->refCount-- <= 1) {
	Itcl_DeleteMemberFunc(clientData);
    }
}

void
ItclPreserveMemberCode(
    ItclMemberCode *mcodePtr)
{
static void FreeMemberCode(ItclMemberCode *mcodePtr);

    mcodePtr->refCount++;
}

void
ItclReleaseMemberCode(
    ItclMemberCode *mcodePtr)
{
    if (mcodePtr->refCount-- <= 1) {
	ItclFreeMemberCode(mcodePtr);
    }
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_BodyCmd()
 *
 *  Invoked by Tcl whenever the user issues an "itcl::body" command to
 *  define or redefine the implementation for a class method/proc.
 *  Handles the following syntax:
306
307
308
309
310
311
312
313

314
315
316

317
318
319
320
321
322
323
272
273
274
275
276
277
278

279
280
281

282
283
284
285
286
287
288
289







-
+


-
+








    if (Itcl_CreateMemberCode(interp, iclsPtr, NULL, token,
            &mcode) != TCL_OK) {
        status = TCL_ERROR;
        goto configBodyCmdDone;
    }

    ItclPreserveMemberCode(mcode);
    Itcl_PreserveData(mcode);

    if (ivPtr->codePtr) {
        ItclReleaseMemberCode(ivPtr->codePtr);
        Itcl_ReleaseData(ivPtr->codePtr);
    }
    ivPtr->codePtr = mcode;

configBodyCmdDone:
    Tcl_DStringFree(&buffer);
    return status;
}
513
514
515
516
517
518
519
520
521


522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537

538
539
540
541
542
543
544
479
480
481
482
483
484
485


486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502

503
504
505
506
507
508
509
510







-
-
+
+















-
+







        Tcl_DeleteHashEntry(hPtr);
        return TCL_ERROR;
    }

    /*
     *  Allocate a member function definition and return.
     */
    imPtr = (ItclMemberFunc*)ckalloc(sizeof(ItclMemberFunc));
    memset(imPtr, 0, sizeof(ItclMemberFunc));
    imPtr = (ItclMemberFunc*)Itcl_Alloc(sizeof(ItclMemberFunc));
    Itcl_EventuallyFree(imPtr, (Tcl_FreeProc *)Itcl_DeleteMemberFunc);
    imPtr->iclsPtr    = iclsPtr;
    imPtr->infoPtr    = iclsPtr->infoPtr;
    imPtr->protection = Itcl_Protection(interp, 0);
    imPtr->namePtr    = Tcl_NewStringObj(Tcl_GetString(namePtr), -1);
    Tcl_IncrRefCount(imPtr->namePtr);
    imPtr->fullNamePtr = Tcl_NewStringObj(
            Tcl_GetString(iclsPtr->fullNamePtr), -1);
    Tcl_AppendToObj(imPtr->fullNamePtr, "::", 2);
    Tcl_AppendToObj(imPtr->fullNamePtr, Tcl_GetString(namePtr), -1);
    Tcl_IncrRefCount(imPtr->fullNamePtr);
    if (arglist != NULL) {
        imPtr->origArgsPtr = Tcl_NewStringObj(arglist, -1);
        Tcl_IncrRefCount(imPtr->origArgsPtr);
    }
    imPtr->codePtr    = mcode;
    ItclPreserveMemberCode(mcode);
    Itcl_PreserveData(mcode);

    if (imPtr->protection == ITCL_DEFAULT_PROTECT) {
        imPtr->protection = ITCL_PUBLIC;
    }

    imPtr->declaringClassPtr = iclsPtr;

673
674
675
676
677
678
679
680

681
682
683
684
685
686
687
639
640
641
642
643
644
645

646
647
648
649
650
651
652
653







-
+







        imPtr->flags |= ITCL_CONSTRUCTOR;
    }
    if (strcmp(name, "destructor") == 0) {
        imPtr->flags |= ITCL_DESTRUCTOR;
    }

    Tcl_SetHashValue(hPtr, imPtr);
    imPtr->refCount = 1;
    Itcl_PreserveData(imPtr);

    *imPtrPtr = imPtr;
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
763
764
765
766
767
768
769

770

771
772
773
774
775
776
777
729
730
731
732
733
734
735
736

737
738
739
740
741
742
743
744







+
-
+







	}
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "argument list changed for function \"",
            Tcl_GetString(imPtr->fullNamePtr), "\": should be \"",
            argsStr, "\"",
            NULL);

	Itcl_PreserveData(mcode);
        Itcl_DeleteMemberCode(mcode);
	Itcl_ReleaseData(mcode);
        return TCL_ERROR;
    }

    if (imPtr->flags & ITCL_CONSTRUCTOR) {
	/*
	 * REVISE mcode->bodyPtr here!
	 * Include a [my ItclConstructBase $iclsPtr] method call.
789
790
791
792
793
794
795
796
797


798
799
800
801
802
803
804
756
757
758
759
760
761
762


763
764
765
766
767
768
769
770
771







-
-
+
+







	mcode->bodyPtr = newBody;
	Tcl_IncrRefCount(mcode->bodyPtr);
    }

    /*
     *  Free up the old implementation and install the new one.
     */
    ItclPreserveMemberCode(mcode);
    ItclReleaseMemberCode(imPtr->codePtr);
    Itcl_PreserveData(mcode);
    Itcl_ReleaseData(imPtr->codePtr);
    imPtr->codePtr = mcode;
    if (mcode->flags & ITCL_IMPLEMENT_TCL) {
	ClientData pmPtr;
        imPtr->tmPtr = Itcl_NewProcClassMethod(interp,
	    imPtr->iclsPtr->clsPtr, ItclCheckCallMethod, ItclAfterCallMethod,
	    ItclProcErrorProc, imPtr, imPtr->namePtr, mcode->argumentPtr,
	    mcode->bodyPtr, &pmPtr);
856
857
858
859
860
861
862
863
864


865
866
867
868

869

870
871
872
873
874
875
876
823
824
825
826
827
828
829


830
831
832
833
834
835
836

837
838
839
840
841
842
843
844







-
-
+
+




+
-
+







    ItclMemberCode *mcode;
    const char **cPtrPtr;
    int haveError;

    /*
     *  Allocate some space to hold the implementation.
     */
    mcode = (ItclMemberCode*)ckalloc(sizeof(ItclMemberCode));
    memset(mcode, 0, sizeof(ItclMemberCode));
    mcode = (ItclMemberCode*)Itcl_Alloc(sizeof(ItclMemberCode));
    Itcl_EventuallyFree(mcode, (Tcl_FreeProc *)FreeMemberCode);

    if (arglist) {
        if (ItclCreateArgList(interp, arglist, &argc, &maxArgc, &usagePtr,
	        &argListPtr, NULL, NULL) != TCL_OK) {
	    Itcl_PreserveData(mcode);
            Itcl_DeleteMemberCode(mcode);
	    Itcl_ReleaseData(mcode);
            return TCL_ERROR;
        }
        mcode->argcount = argc;
        mcode->maxargcount = maxArgc;
        mcode->argListPtr = argListPtr;
        mcode->usagePtr = usagePtr;
	Tcl_IncrRefCount(mcode->usagePtr);
905
906
907
908
909
910
911

912

913
914
915
916
917
918
919
873
874
875
876
877
878
879
880

881
882
883
884
885
886
887
888







+
-
+







			    startStr = "";
			}
		        Tcl_AppendResult(interp, startStr,
				namePtr == NULL ? "??" :
			        Tcl_GetString(namePtr),
				"'s arglist may not contain \"",
				*cPtrPtr, "\" explicitly", NULL);
			Itcl_PreserveData(mcode);
                        Itcl_DeleteMemberCode(mcode);
			Itcl_ReleaseData(mcode);
                        return TCL_ERROR;
		    }
		    cPtrPtr++;
	        }
	        argListPtr = argListPtr->nextPtr;
	    }
	}
1022
1023
1024
1025
1026
1027
1028

1029

1030
1031
1032
1033
1034
1035
1036
991
992
993
994
995
996
997
998

999
1000
1001
1002
1003
1004
1005
1006







+
-
+







	    }
	    if (!isDone) {
                if (!Itcl_FindC(interp, body+1, &argCmdProc, &objCmdProc,
		        &cdata)) {
		    Tcl_AppendResult(interp,
                            "no registered C procedure with name \"",
			    body+1, "\"", NULL);
		    Itcl_PreserveData(mcode);
                    Itcl_DeleteMemberCode(mcode);
		    Itcl_ReleaseData(mcode);
                    return TCL_ERROR;
                }

	/*
	 * WARNING! WARNING! WARNING!
	 * This is a pretty dangerous approach.  What's done here is
	 * to copy over the proc + clientData implementation that
1076
1077
1078
1079
1080
1081
1082
1083

1084
1085
1086
1087
1088
1089
1090
1046
1047
1048
1049
1050
1051
1052

1053
1054
1055
1056
1057
1058
1059
1060







-
+







 *
 *  Creates the data record representing the implementation behind a
 *  class member function.  This includes the argument list and the body
 *  of the function.  If the body is of the form "@name", then it is
 *  treated as a label for a C procedure registered by Itcl_RegisterC().
 *
 *  A member function definition holds a handle for the implementation, and
 *  calls ItclReleaseMemberCode when finished with it.
 *  uses Itcl_PreserveData and Itcl_ReleaseData to manage its interest in it.
 *
 *  If any errors are encountered, this procedure returns TCL_ERROR
 *  along with an error message in the interpreter.  Otherwise, it
 *  returns TCL_OK, and stores a pointer to the new implementation in
 *  "mcodePtr".
 * ------------------------------------------------------------------------
 */
1105
1106
1107
1108
1109
1110
1111
1112

1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130

1131
1132
1133
1134
1135
1136
1137
1138

1139
1140
1141
1142
1143
1144
1145
1075
1076
1077
1078
1079
1080
1081

1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099

1100
1101
1102
1103
1104
1105
1106
1107

1108
1109
1110
1111
1112
1113
1114
1115







-
+

















-
+







-
+







 *  Itcl_DeleteMemberCode()
 *
 *  Destroys all data associated with the given command implementation.
 *  Invoked automatically by ItclReleaseData() when the implementation
 *  is no longer being used.
 * ------------------------------------------------------------------------
 */
void ItclFreeMemberCode (
void FreeMemberCode (
    ItclMemberCode* mCodePtr)
{
    if (mCodePtr == NULL) {
        return;
    }
    if (mCodePtr->argListPtr != NULL) {
        ItclDeleteArgList(mCodePtr->argListPtr);
    }
    if (mCodePtr->usagePtr != NULL) {
        Tcl_DecrRefCount(mCodePtr->usagePtr);
    }
    if (mCodePtr->argumentPtr != NULL) {
        Tcl_DecrRefCount(mCodePtr->argumentPtr);
    }
    if (mCodePtr->bodyPtr != NULL) {
        Tcl_DecrRefCount(mCodePtr->bodyPtr);
    }
    ckfree((char*)mCodePtr);
    Itcl_Free(mCodePtr);
}


void
Itcl_DeleteMemberCode(
    void* cdata)  /* pointer to member code definition */
{
    ItclReleaseMemberCode((ItclMemberCode *)cdata);
    Itcl_ReleaseData((ItclMemberCode *)cdata);
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_GetMemberCode()
 *
1286
1287
1288
1289
1290
1291
1292
1293

1294
1295
1296
1297
1298
1299
1300
1256
1257
1258
1259
1260
1261
1262

1263
1264
1265
1266
1267
1268
1269
1270







-
+







    }
    mcode = imPtr->codePtr;

    /*
     *  Bump the reference count on this code, in case it is
     *  redefined or deleted during execution.
     */
    ItclPreserveMemberCode(mcode);
    Itcl_PreserveData(mcode);

    if ((imPtr->flags & ITCL_DESTRUCTOR) && (contextIoPtr != NULL)) {
        contextIoPtr->destructorHasBeenCalled = 1;
    }

    /*
     *  Execute the code body...
1324
1325
1326
1327
1328
1329
1330
1331

1332
1333
1334
1335
1336
1337
1338
1294
1295
1296
1297
1298
1299
1300

1301
1302
1303
1304
1305
1306
1307
1308







-
+







            callbackPtr = Itcl_GetCurrentCallbackPtr(interp);
            Tcl_NRAddCallback(interp, CallItclObjectCmd, imPtr, contextIoPtr,
	            INT2PTR(objc), (void *)objv);
            result = Itcl_NRRunCallbacks(interp, callbackPtr);
         }
    }

    ItclReleaseMemberCode(mcode);
    Itcl_ReleaseData(mcode);
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  ItclEquivArgLists()
 *
1725
1726
1727
1728
1729
1730
1731
1732

1733
1734

1735
1736
1737
1738
1739
1740
1741
1695
1696
1697
1698
1699
1700
1701

1702
1703

1704
1705
1706
1707
1708
1709
1710
1711







-
+

-
+







        }
    }

    /*
     *  Execute the code for the method.  Be careful to protect
     *  the method in case it gets deleted during execution.
     */
    ItclPreserveIMF(imPtr);
    Itcl_PreserveData(imPtr);
    result = Itcl_EvalMemberCode(interp, imPtr, ioPtr, objc, objv);
    ItclReleaseIMF(imPtr);
    Itcl_ReleaseData(imPtr);
    return result;
}

/* ARGSUSED */
int
Itcl_ExecMethod(
    ClientData clientData,
1811
1812
1813
1814
1815
1816
1817
1818

1819
1820
1821
1822

1823
1824
1825
1826
1827
1828
1829
1781
1782
1783
1784
1785
1786
1787

1788
1789
1790
1791

1792
1793
1794
1795
1796
1797
1798
1799







-
+



-
+







        }
    }

    /*
     *  Execute the code for the proc.  Be careful to protect
     *  the proc in case it gets deleted during execution.
     */
    ItclPreserveIMF(imPtr);
    Itcl_PreserveData(imPtr);

    result = Itcl_EvalMemberCode(interp, imPtr, NULL,
        objc, objv);
    ItclReleaseIMF(imPtr);
    Itcl_ReleaseData(imPtr);
    return result;
}

/* ARGSUSED */
int
Itcl_ExecProc(
    ClientData clientData,
2008
2009
2010
2011
2012
2013
2014
2015

2016
2017
2018
2019
2020
2021
2022
2023

2024
2025
2026
2027
2028
2029
2030
1978
1979
1980
1981
1982
1983
1984

1985
1986
1987
1988
1989
1990
1991
1992

1993
1994
1995
1996
1997
1998
1999
2000







-
+







-
+







            &cmdlinec, &cmdlinev);

        ItclShowArgs(1, "EMC", cmdlinec, cmdlinev);
        /*
         *  Execute the code for the method.  Be careful to protect
         *  the method in case it gets deleted during execution.
         */
	ItclPreserveIMF(imPtr);
	Itcl_PreserveData(imPtr);

	if (contextObjectPtr->oPtr == NULL) {
            Tcl_DecrRefCount(cmdlinePtr);
            return TCL_ERROR;
	}
        result = Itcl_EvalMemberCode(interp, imPtr, contextObjectPtr,
	        cmdlinec, cmdlinev);
	ItclReleaseIMF(imPtr);
	Itcl_ReleaseData(imPtr);
        Tcl_DecrRefCount(cmdlinePtr);
    } else {
        if (contextClassPtr->flags &
	        (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
	    if (strcmp(name, "constructor") == 0) {
                if (objc > 0) {
                    if (contextClassPtr->numOptions == 0) {
2346
2347
2348
2349
2350
2351
2352
2353

2354
2355
2356
2357
2358
2359
2360
2316
2317
2318
2319
2320
2321
2322

2323
2324
2325
2326
2327
2328
2329
2330







-
+







    int min_allowed_args;

    ItclObjectInfo *infoPtr;

    oPtr = NULL;
    hPtr = NULL;
    imPtr = (ItclMemberFunc *)clientData;
    ItclPreserveIMF(imPtr);
    Itcl_PreserveData(imPtr);
    if (imPtr->flags & ITCL_CONSTRUCTOR) {
        ioPtr = imPtr->iclsPtr->infoPtr->currIoPtr;
    } else {
	if (contextPtr == NULL) {
	    if ((imPtr->flags & ITCL_COMMON) ||
                    (imPtr->codePtr->flags & ITCL_BUILTIN)) {
                if (!imPtr->iclsPtr->infoPtr->useOldResolvers) {
2483
2484
2485
2486
2487
2488
2489
2490

2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503

2504
2505
2506
2507
2508
2509
2510
2453
2454
2455
2456
2457
2458
2459

2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472

2473
2474
2475
2476
2477
2478
2479
2480







-
+












-
+







	stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr);
    }

    Itcl_PushStack(framePtr, stackPtr);

    if (ioPtr != NULL) {
        ioPtr->callRefCount++;
	ItclPreserveObject(ioPtr);
	Itcl_PreserveData(ioPtr);
    }
    imPtr->iclsPtr->callRefCount++;
    if (!imPtr->iclsPtr->infoPtr->useOldResolvers) {
        Itcl_SetCallFrameResolver(interp, ioPtr->resolvePtr);
    }
    result = TCL_OK;

    if (isFinished != NULL) {
        *isFinished = 0;
    }
    return result;
finishReturn:
    ItclReleaseIMF(imPtr);
    Itcl_ReleaseData(imPtr);
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  ItclAfterCallMethod()
 *
2597
2598
2599
2600
2601
2602
2603
2604

2605
2606
2607
2608
2609
2610
2611

2612
2613
2614
2615
2616
2617
2618
2567
2568
2569
2570
2571
2572
2573

2574
2575
2576
2577
2578
2579
2580

2581
2582
2583
2584
2585
2586
2587
2588







-
+






-
+







    if (callContextPtr->refCount-- <= 1) {
        if (callContextPtr->ioPtr != NULL) {
	    hPtr = Tcl_FindHashEntry(&callContextPtr->ioPtr->contextCache,
	            (char *)callContextPtr->imPtr);
            if (hPtr == NULL) {
                ckfree((char *)callContextPtr);
	    }
	    ItclReleaseObject(ioPtr);
	    Itcl_ReleaseData(ioPtr);
        } else {
            ckfree((char *)callContextPtr);
        }
    }
    result = call_result;
finishReturn:
    ItclReleaseIMF(imPtr);
    Itcl_ReleaseData(imPtr);
    return result;
}

void
ItclProcErrorProc(
    Tcl_Interp *interp,
    Tcl_Obj *procNameObj)
Changes to generic/itclObject.c.
49
50
51
52
53
54
55
56

57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
49
50
51
52
53
54
55

56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72


















73
74
75
76
77
78
79







-
+
















-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-







	const char *name1, const char *name2, int flags);
static char* ItclTraceComponentVar(ClientData cdata, Tcl_Interp *interp,
	const char *name1, const char *name2, int flags);
static char* ItclTraceItclHullVar(ClientData cdata, Tcl_Interp *interp,
	const char *name1, const char *name2, int flags);

static void ItclDestroyObject(ClientData clientData);
static void ItclFreeObject(char * clientData);
static Tcl_FreeProc FreeObject;

static int ItclDestructBase(Tcl_Interp *interp, ItclObject *contextObj,
        ItclClass *contextClass, int flags);

static int ItclInitObjectVariables(Tcl_Interp *interp, ItclObject *ioPtr,
        ItclClass *iclsPtr);
static int ItclInitObjectCommands(Tcl_Interp *interp, ItclObject *ioPtr,
        ItclClass *iclsPtr, const char *name);
static int ItclInitExtendedClassOptions(Tcl_Interp *interp, ItclObject *ioPtr);
static int ItclInitObjectOptions(Tcl_Interp *interp, ItclObject *ioPtr,
        ItclClass *iclsPtr);
static const char * GetConstructorVar(Tcl_Interp *interp, ItclClass *iclsPtr,
        const char *varName);
static ItclClass * GetClassFromClassName(Tcl_Interp *interp,
	const char *className, ItclClass *iclsPtr);

void
ItclPreserveObject(
    ItclObject *ioPtr)
{
    ioPtr->refCount++;
}

void
ItclReleaseObject(
    ClientData clientData)
{
    ItclObject *ioPtr = (ItclObject *)clientData;

    if (ioPtr->refCount-- <= 1) {
	ItclFreeObject((char *) clientData);
    }
}


/*
 * ------------------------------------------------------------------------
 *  ItclDeleteObjectMetadata()
 *
 *  Delete the metadata data if any
 *-------------------------------------------------------------------------
261
262
263
264
265
266
267
268
269


270
271
272
273
274
275
276
277
278
279
280
281

282
283
284
285
286
287
288
289
290

291
292
293
294
295
296
297
243
244
245
246
247
248
249


250
251
252
253
254
255
256
257
258
259
260
261
262

263
264
265
266
267
268
269
270
271

272
273
274
275
276
277
278
279







-
-
+
+











-
+








-
+








    if (infoPtr != NULL) {
      infoPtr->lastIoPtr = NULL;
    }
    /*
     *  Create a new object and initialize it.
     */
    ioPtr = (ItclObject*)ckalloc(sizeof(ItclObject));
    memset(ioPtr, 0, sizeof(ItclObject));
    ioPtr = (ItclObject*)Itcl_Alloc(sizeof(ItclObject));
    Itcl_EventuallyFree(ioPtr, FreeObject);
    ioPtr->iclsPtr = iclsPtr;
    ioPtr->interp = interp;
    ioPtr->infoPtr = infoPtr;
    ItclPreserveClass(iclsPtr);

    ioPtr->constructed = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
    Tcl_InitObjHashTable(ioPtr->constructed);

    ioPtr->oPtr = Tcl_NewObjectInstance(interp, iclsPtr->clsPtr, NULL,
            /* nsName */ NULL, /* objc */ -1, /* objv */ NULL, /* skip */ 0);
    if (ioPtr->oPtr == NULL) {
	ckfree(ioPtr);
	Itcl_Free(ioPtr);
        return TCL_ERROR;
    }

    /*
     *  Add a command to the current namespace with the object name.
     *  This is done before invoking the constructors so that the
     *  command can be used during construction to query info.
     */
    ItclPreserveObject(ioPtr);
    Itcl_PreserveData(ioPtr);

    ioPtr->namePtr = Tcl_NewStringObj(name, -1);
    Tcl_IncrRefCount(ioPtr->namePtr);
    nsName = Tcl_GetCurrentNamespace(interp)->fullName;
    ioPtr->origNamePtr = Tcl_NewStringObj("", -1);
    if ((name[0] != ':') && (name[1] != ':')) {
        Tcl_AppendToObj(ioPtr->origNamePtr, nsName, -1);
313
314
315
316
317
318
319
320

321
322
323
324
325
326
327
295
296
297
298
299
300
301

302
303
304
305
306
307
308
309







-
+







    Tcl_InitObjHashTable(&ioPtr->objectOptions);
    Tcl_InitObjHashTable(&ioPtr->objectComponents);
    Tcl_InitObjHashTable(&ioPtr->objectDelegatedOptions);
    Tcl_InitObjHashTable(&ioPtr->objectDelegatedFunctions);
    Tcl_InitObjHashTable(&ioPtr->objectMethodVariables);
    Tcl_InitHashTable(&ioPtr->contextCache, TCL_ONE_WORD_KEYS);

    ItclPreserveObject(ioPtr);
    Itcl_PreserveData(ioPtr);

    /*
     *  Install the class namespace and object context so that
     *  the object's data members can be initialized via simple
     *  "set" commands.
     */

508
509
510
511
512
513
514
515

516
517
518
519
520
521
522
490
491
492
493
494
495
496

497
498
499
500
501
502
503
504







-
+







	if (ioPtr->accessCmd != (Tcl_Command) NULL) {
	    Tcl_DeleteCommandFromToken(interp, ioPtr->accessCmd);
	    ioPtr->accessCmd = NULL;
	}
        result = Itcl_RestoreInterpState(interp, istate);
	infoPtr->currIoPtr = saveCurrIoPtr;
	/* need this for 2 ReleaseData at errorReturn!! */
	ItclPreserveObject(ioPtr);
	Itcl_PreserveData(ioPtr);
        goto errorReturn;
    } else {
	/* a constructor cannot return a result as the object name
	 * is returned as result */
        Tcl_ResetResult(interp);
    }

557
558
559
560
561
562
563
564

565
566
567
568
569
570
571
539
540
541
542
543
544
545

546
547
548
549
550
551
552
553







-
+







	 */
	if (ioPtr->accessCmd != (Tcl_Command) NULL) {
	    Tcl_DeleteCommandFromToken(interp, ioPtr->accessCmd);
	    ioPtr->accessCmd = NULL;
	}
        result = Itcl_RestoreInterpState(interp, istate);
	/* need this for 2 ReleaseData at errorReturn!! */
	ItclPreserveObject(ioPtr);
	Itcl_PreserveData(ioPtr);
        goto errorReturn;
    }

    if (iclsPtr->flags & ITCL_WIDGETADAPTOR) {

	if (saveNsNamePtr) {
	    Tcl_SetVar2Ex(interp, "::itcl::internal::varNsName", name,
609
610
611
612
613
614
615
616

617
618
619
620
621
622
623
591
592
593
594
595
596
597

598
599
600
601
602
603
604
605







-
+







            istate = Itcl_SaveInterpState(interp, result);
	    if (ioPtr->accessCmd != (Tcl_Command) NULL) {
	        Tcl_DeleteCommandFromToken(interp, ioPtr->accessCmd);
	        ioPtr->accessCmd = NULL;
	    }
            result = Itcl_RestoreInterpState(interp, istate);
	    /* need this for 2 ReleaseData at errorReturn!! */
	    ItclPreserveObject(ioPtr);
	    Itcl_PreserveData(ioPtr);
            goto errorReturn;
	}
    }

    /*
     *  Add it to the list of all known objects. The only
     *  tricky thing to watch out for is the case where the
701
702
703
704
705
706
707
708

709
710
711
712
713
714
715
683
684
685
686
687
688
689

690
691
692
693
694
695
696
697







-
+







        infoPtr->currIoPtr = saveCurrIoPtr;
    }
    infoPtr->lastIoPtr = ioPtr;
    Tcl_DeleteHashTable(ioPtr->constructed);
    ckfree((char*)ioPtr->constructed);
    ioPtr->constructed = NULL;
    ItclAddObjectsDictInfo(interp, ioPtr);
    ItclReleaseObject(ioPtr);
    Itcl_ReleaseData(ioPtr);
    return result;

errorReturn:
    /*
     *  At this point, the object is not constructed as there was an error.
     *  Destroy the "constructed" table in the object data, since
     *  it is no longer needed.
726
727
728
729
730
731
732
733
734


735
736
737
738
739
740
741
708
709
710
711
712
713
714


715
716
717
718
719
720
721
722
723







-
-
+
+







    }
    if (ioPtr->constructed != NULL) {
        Tcl_DeleteHashTable(ioPtr->constructed);
        ckfree((char*)ioPtr->constructed);
        ioPtr->constructed = NULL;
    }
    ItclDeleteObjectVariablesNamespace(interp, ioPtr);
    ItclReleaseObject(ioPtr);
    ItclReleaseObject(ioPtr);
    Itcl_ReleaseData(ioPtr);
    Itcl_ReleaseData(ioPtr);
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  ItclInitObjectCommands()
 *
1221
1222
1223
1224
1225
1226
1227
1228

1229
1230
1231
1232
1233
1234

1235
1236
1237
1238
1239
1240
1241
1203
1204
1205
1206
1207
1208
1209

1210
1211
1212
1213
1214
1215

1216
1217
1218
1219
1220
1221
1222
1223







-
+





-
+







    Tcl_CmdInfo cmdInfo;
    Tcl_HashEntry *hPtr;


    Tcl_GetCommandInfoFromToken(contextIoPtr->accessCmd, &cmdInfo);

    contextIoPtr->flags |= ITCL_OBJECT_IS_DELETED;
    ItclPreserveObject(contextIoPtr);
    Itcl_PreserveData(contextIoPtr);

    /*
     *  Invoke the object's destructors.
     */
    if (Itcl_DestructObject(interp, contextIoPtr, 0) != TCL_OK) {
	ItclReleaseObject(contextIoPtr);
	Itcl_ReleaseData(contextIoPtr);
	contextIoPtr->flags |=
	        ITCL_TCLOO_OBJECT_IS_DELETED|ITCL_OBJECT_DESTRUCT_ERROR;
        return TCL_ERROR;
    }
    /*
     *  Remove the object from the global list.
     */
1251
1252
1253
1254
1255
1256
1257
1258

1259
1260
1261
1262
1263
1264
1265
1266
1267

1268
1269
1270
1271
1272
1273
1274
1233
1234
1235
1236
1237
1238
1239

1240
1241
1242
1243
1244
1245
1246
1247
1248

1249
1250
1251
1252
1253
1254
1255
1256







-
+








-
+







     *  safely deleted without attempting to destruct the object
     *  again.  Then delete the access command.  If this is
     *  the last use of the object data, the object will die here.
     */
    if ((contextIoPtr->accessCmd != NULL) && (!(contextIoPtr->flags &
            (ITCL_OBJECT_IS_RENAMED)))) {
    if (Tcl_GetCommandInfoFromToken(contextIoPtr->accessCmd, &cmdInfo) == 1) {
        cmdInfo.deleteProc = ItclReleaseObject;
        cmdInfo.deleteProc = (Tcl_CmdDeleteProc *)Itcl_ReleaseData;
	Tcl_SetCommandInfoFromToken(contextIoPtr->accessCmd, &cmdInfo);

        Tcl_DeleteCommandFromToken(interp, contextIoPtr->accessCmd);
    }
    }
    contextIoPtr->oPtr = NULL;
    contextIoPtr->accessCmd = NULL;

    ItclReleaseObject(contextIoPtr);
    Itcl_ReleaseData(contextIoPtr);

    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  ItclDeleteObjectVariablesNamespace()
2633
2634
2635
2636
2637
2638
2639
2640

2641
2642
2643
2644
2645

2646
2647
2648

2649
2650
2651
2652
2653

2654
2655
2656
2657
2658
2659
2660
2615
2616
2617
2618
2619
2620
2621

2622
2623
2624
2625
2626

2627
2628
2629

2630

2631
2632
2633

2634
2635
2636
2637
2638
2639
2640
2641







-
+




-
+


-
+
-



-
+







            (char*)contextIoPtr);

        if (hPtr) {
            Tcl_DeleteHashEntry(hPtr);
        }
        contextIoPtr->accessCmd = NULL;
    }
    ItclReleaseObject(contextIoPtr);
    Itcl_ReleaseData(contextIoPtr);
}

/*
 * ------------------------------------------------------------------------
 *  ItclFreeObject()
 *  FreeObject()
 *
 *  Deletes all instance variables and frees all memory associated with
 *  the given object instance.  This is usually invoked automatically
 *  the given object instance.  Called when releases match preserves.
 *  by ItclReleaseObject(), when an object's data is no longer being used.
 * ------------------------------------------------------------------------
 */
static void
ItclFreeObject(
FreeObject(
    char * cdata)  /* object instance data */
{
    FOREACH_HASH_DECLS;
    Tcl_HashSearch place;
    ItclCallContext *callContextPtr;
    ItclObject *ioPtr;
    Tcl_Var var;
2715
2716
2717
2718
2719
2720
2721
2722

2723
2724
2725
2726
2727
2728
2729
2696
2697
2698
2699
2700
2701
2702

2703
2704
2705
2706
2707
2708
2709
2710







-
+







        Tcl_DecrRefCount(ioPtr->hullWindowNamePtr);
    }
    Tcl_DecrRefCount(ioPtr->varNsNamePtr);
    if (ioPtr->resolvePtr != NULL) {
	ckfree((char *)ioPtr->resolvePtr->clientData);
        ckfree((char*)ioPtr->resolvePtr);
    }
    ckfree((char*)ioPtr);
    Itcl_Free(ioPtr);
}

/*
 * ------------------------------------------------------------------------
 *  ItclObjectCmd()
 *
 * ------------------------------------------------------------------------
Changes to generic/itclParse.c.
635
636
637
638
639
640
641
642

643
644
645
646
647
648
649
650

651
652
653
654
655
656
657
658
659
660

661
662
663
664
665
666
667
635
636
637
638
639
640
641

642
643
644
645
646
647
648
649

650
651
652
653
654
655
656
657
658
659

660
661
662
663
664
665
666
667







-
+







-
+









-
+







static Tcl_MethodCallProc ArgCallProc;
static Tcl_CloneProc CloneProc;

static const Tcl_MethodType itclObjMethodType = {
    TCL_OO_METHOD_VERSION_CURRENT,
    "itcl objv method",
    ObjCallProc,
    ItclReleaseIMF,
    Itcl_ReleaseData,
    CloneProc
};

static const Tcl_MethodType itclArgMethodType = {
    TCL_OO_METHOD_VERSION_CURRENT,
    "itcl argv method",
    ArgCallProc,
    ItclReleaseIMF,
    Itcl_ReleaseData,
    CloneProc
};

static int
CloneProc(
    Tcl_Interp *interp,
    ClientData original,
    ClientData *copyPtr)
{
    ItclPreserveIMF((ItclMemberFunc *)original);
    Itcl_PreserveData((ItclMemberFunc *)original);
    *copyPtr = original;
    return TCL_OK;
}

static int
CallAfterCallMethod(
    ClientData data[],
877
878
879
880
881
882
883
884

885
886
887
888
889

890
891
892
893
894
895
896
897
898

899
900
901
902
903
904
905
877
878
879
880
881
882
883

884
885
886
887
888

889
890
891
892
893
894
895
896
897

898
899
900
901
902
903
904
905







-
+




-
+








-
+







	    bodyPtr = imPtr->codePtr->bodyPtr;

if (imPtr->codePtr->flags & ITCL_IMPLEMENT_OBJCMD) {
    /* Implementation of this member is coded in C expecting Tcl_Obj */

    imPtr->tmPtr = Tcl_NewMethod(interp, iclsPtr->clsPtr, imPtr->namePtr,
	    1, &itclObjMethodType, imPtr);
    ItclPreserveIMF(imPtr);
    Itcl_PreserveData(imPtr);

    if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
	imPtr->tmPtr = Tcl_NewInstanceMethod(interp, iclsPtr->oPtr,
		imPtr->namePtr, 1, &itclObjMethodType, imPtr);
	ItclPreserveIMF(imPtr);
	Itcl_PreserveData(imPtr);
    }

} else if (imPtr->codePtr->flags & ITCL_IMPLEMENT_ARGCMD) {
    /* Implementation of this member is coded in C expecting (char *) */

    imPtr->tmPtr = Tcl_NewMethod(interp, iclsPtr->clsPtr, imPtr->namePtr,
	    1, &itclArgMethodType, imPtr);

		ItclPreserveIMF(imPtr);
		Itcl_PreserveData(imPtr);



} else {
	    if (imPtr->codePtr->flags & ITCL_BUILTIN) {
		int isDone;
		isDone = 0;
1084
1085
1086
1087
1088
1089
1090
1091
1092


1093
1094
1095
1096
1097


1098
1099
1100
1101
1102
1103
1104
1084
1085
1086
1087
1088
1089
1090


1091
1092
1093
1094
1095


1096
1097
1098
1099
1100
1101
1102
1103
1104







-
-
+
+



-
-
+
+







                    ItclProcErrorProc, imPtr, imPtr->namePtr, argumentPtr,
		    bodyPtr, &pmPtr);
	    }
}
	    if ((imPtr->flags & ITCL_COMMON) == 0) {
	        imPtr->accessCmd = Tcl_CreateObjCommand(interp,
		        Tcl_GetString(imPtr->fullNamePtr),
		        Itcl_ExecMethod, imPtr, ItclReleaseIMF);
		ItclPreserveIMF(imPtr);
		        Itcl_ExecMethod, imPtr, Itcl_ReleaseData);
		Itcl_PreserveData(imPtr);
	    } else {
	        imPtr->accessCmd = Tcl_CreateObjCommand(interp,
		        Tcl_GetString(imPtr->fullNamePtr),
			Itcl_ExecProc, imPtr, ItclReleaseIMF);
		ItclPreserveIMF(imPtr);
			Itcl_ExecProc, imPtr, Itcl_ReleaseData);
		Itcl_PreserveData(imPtr);
	    }
    }
    if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
	/* initialize the typecomponents and typevariables */
        if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr,
                /*isProcCallFrame*/0) != TCL_OK) {
	    result = TCL_ERROR;
2414
2415
2416
2417
2418
2419
2420
2421

2422
2423
2424
2425
2426
2427
2428
2414
2415
2416
2417
2418
2419
2420

2421
2422
2423
2424
2425
2426
2427
2428







-
+







	    hPtr = Tcl_FirstHashEntry(&infoPtr->objects, &place);
	    /*hPtr = Tcl_NextHashEntry(&place);*/
    }
    Tcl_DeleteHashTable(&infoPtr->objects);
    Tcl_DeleteHashTable(&infoPtr->frameContext);

    Itcl_DeleteStack(&infoPtr->clsStack);
    ckfree((char*)infoPtr);
    Itcl_Free(infoPtr);
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassFilterCmd()
 *
 *
2827
2828
2829
2830
2831
2832
2833
2834

2835
2836
2837
2838
2839
2840
2841
2842
2827
2828
2829
2830
2831
2832
2833

2834

2835
2836
2837
2838
2839
2840
2841







-
+
-







    }
    classNamePtr = ItclCapitalize(className);
    init = defaultValue;
    if ((newObjc > 1) && (init == NULL)) {
        init = Tcl_GetString(newObjv[1]);
    }

    ioptPtr = (ItclOption*)ckalloc(sizeof(ItclOption));
    ioptPtr = (ItclOption*)Itcl_Alloc(sizeof(ItclOption));
    memset(ioptPtr, 0, sizeof(ItclOption));
    ioptPtr->protection   = Itcl_Protection(interp, 0);
    if (ioptPtr->protection == ITCL_DEFAULT_PROTECT) {
        ioptPtr->protection = ITCL_PROTECTED;
    }
    ioptPtr->namePtr      = Tcl_NewStringObj(name, -1);
    Tcl_IncrRefCount(ioptPtr->namePtr);
    ioptPtr->resourceNamePtr = Tcl_NewStringObj(resourceName, -1);
3768
3769
3770
3771
3772
3773
3774
3775
3776

3777
3778
3779
3780
3781
3782
3783
3767
3768
3769
3770
3771
3772
3773


3774
3775
3776
3777
3778
3779
3780
3781







-
-
+







	if (hPtr != NULL) {
	    Tcl_AppendResult(interp, "option \"", option,
	            "\" has been defined locally", NULL);
	    goto errorOut1;
	    return TCL_ERROR;
	}
    }
    idoPtr = (ItclDelegatedOption *)ckalloc(sizeof(ItclDelegatedOption));
    memset(idoPtr, 0, sizeof(ItclDelegatedOption));
    idoPtr = (ItclDelegatedOption *)Itcl_Alloc(sizeof(ItclDelegatedOption));
    Tcl_InitObjHashTable(&idoPtr->exceptions);
    if (*option != '*') {
        if (targetPtr == NULL) {
	    targetPtr = optionNamePtr;
	}
        if (resourceNamePtr == NULL) {
	    resourceNamePtr = Tcl_NewStringObj(option+1, -1);
3820
3821
3822
3823
3824
3825
3826
3827

3828
3829
3830
3831
3832
3833
3834
3818
3819
3820
3821
3822
3823
3824

3825
3826
3827
3828
3829
3830
3831
3832







-
+







    if (idoPtrPtr != NULL) {
        *idoPtrPtr = idoPtr;
    }
    ckfree((char *)argv);
    ItclAddDelegatedOptionDictInfo(interp, iclsPtr, idoPtr);
    return TCL_OK;
errorOut2:
    /* FIXME need to decr additional refCount's !! */
    Itcl_ReleaseData(idoPtr);
errorOut1:
    Tcl_DecrRefCount(optionNamePtr);
    if (resourceNamePtr != NULL) {
        Tcl_DecrRefCount(resourceNamePtr);
    }
    if (classNamePtr != NULL) {
        Tcl_DecrRefCount(classNamePtr);
Changes to generic/itclStubInit.c.
231
232
233
234
235
236
237


238
239
240
231
232
233
234
235
236
237
238
239
240
241
242







+
+



    Itcl_SetListValue, /* 19 */
    Itcl_EventuallyFree, /* 20 */
    Itcl_PreserveData, /* 21 */
    Itcl_ReleaseData, /* 22 */
    Itcl_SaveInterpState, /* 23 */
    Itcl_RestoreInterpState, /* 24 */
    Itcl_DiscardInterpState, /* 25 */
    Itcl_Alloc, /* 26 */
    Itcl_Free, /* 27 */
};

/* !END!: Do not edit above this line. */
Changes to generic/itclUtil.c.
25
26
27
28
29
30
31

32
33
34
35
36
37
38
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39







+







 * ========================================================================
 *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */
#include "itclInt.h"
#include <limits.h>

/*
 *  POOL OF LIST ELEMENTS FOR LINKED LIST
 */
static Itcl_ListElem *listPool = NULL;
static int listPoolLen = 0;

483
484
485
486
487
488
489
490
491
492
493

494
495
496
497
498
499
500
484
485
486
487
488
489
490


491

492
493
494
495
496
497
498
499







-
-

-
+







 * ------------------------------------------------------------------------
 */
void
Itcl_SetListValue(
    Itcl_ListElem *elemPtr, /* list element being modified */
    ClientData val)         /* new value associated with element */
{
    Itcl_List *listPtr = elemPtr->owner;
    assert(listPtr->validate == ITCL_VALID_LIST);
    assert(elemPtr != NULL);

    assert(elemPtr->owner->validate == ITCL_VALID_LIST);
    elemPtr->value = val;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_FinishList()
522
523
524
525
526
527
528
529
530
531
532
533
534











535
536
537

538

539
540
541
542


543
544
545
546
547
548
549
550
551


552
553
554
555
556
557



558


559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576

577
578
579
580
581
582
583
584
585






586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601


602






















603

604
605
606
607
608
609
610




















































611
612
613
614
615
616
617
521
522
523
524
525
526
527






528
529
530
531
532
533
534
535
536
537
538
539
540
541
542

543




544
545
546
547
548
549
550
551
552


553
554

555
556
557


558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583



584
585
586


587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633

634







635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693







-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+



+
-
+
-
-
-
-
+
+







-
-
+
+
-



-
-
+
+
+

+
+


















+

-
-
-



-
-
+
+
+
+
+
+
















+
+

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








/*
 * ========================================================================
 *  REFERENCE-COUNTED DATA
 *
 *  The following procedures manage generic reference-counted data.
 *  They are similar in spirit to the Tcl_Preserve/Tcl_Release
 *  procedures defined in the Tcl/Tk core.  But these procedures use
 *  a hash table instead of a linked list to maintain the references,
 *  so they scale better.  Also, the Tcl procedures have a bad behavior
 *  during the "exit" command.  Their exit handler shuts them down
 *  when other data is still being reference-counted and cleaned up.
 *
 *  procedures defined in the Tcl/Tk core.  But these procedures attach a
 *  refcount directly to the allocated memory, and then use it to govern
 *  shared access and properly timed release.
 */

typedef struct PresMemoryPrefix {
    Tcl_FreeProc *freeProc;     /* called by last Itcl_ReleaseData */
    size_t refCount;            /* refernce (resp preserving) counter */
} PresMemoryPrefix;

/*
 * ------------------------------------------------------------------------
 *  Itcl_EventuallyFree()
 *
 *  Asscociates with cdata (allocated by Itcl_Alloc()) a routine to
 *  Registers a piece of data so that it will be freed when no longer
 *  be called when cdata should be freed. This routine will be called
 *  in use.  The data is registered with an initial usage count of "0".
 *  Future calls to Itcl_PreserveData() increase this usage count, and
 *  calls to Itcl_ReleaseData() decrease the count until it reaches
 *  zero and the data is freed.
 *  when the number of Itcl_ReleaseData() calls on cdata  matches the
 *  number of Itcl_PreserveData() calls on cdata.
 * ------------------------------------------------------------------------
 */
void
Itcl_EventuallyFree(
    ClientData cdata,          /* data to be freed when not in use */
    Tcl_FreeProc *fproc)       /* procedure called to free data */
{
    /*
     *  If the clientData value is NULL, do nothing.
    PresMemoryPrefix *blk;

     */
    if (cdata == NULL) {
        return;
    }
    Tcl_EventuallyFree(cdata, fproc);
    return;

    /* Itcl memory block to ckalloc block */
    blk = ((PresMemoryPrefix *)cdata)-1;

    /* Set new free proc */
    blk->freeProc = fproc;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_PreserveData()
 *
 *  Increases the usage count for a piece of data that will be freed
 *  later when no longer needed.  Each call to Itcl_PreserveData()
 *  puts one claim on a piece of data, and subsequent calls to
 *  Itcl_ReleaseData() remove those claims.  When Itcl_EventuallyFree()
 *  is called, and when the usage count reaches zero, the data is
 *  freed.
 * ------------------------------------------------------------------------
 */
void
Itcl_PreserveData(
    ClientData cdata)     /* data to be preserved */
{
    PresMemoryPrefix *blk;

    /*
     *  If the clientData value is NULL, do nothing.
     */
    if (cdata == NULL) {
        return;
    }
    Tcl_Preserve(cdata);
    return;

    /* Itcl memory block to ckalloc block */
    blk = ((PresMemoryPrefix *)cdata)-1;

    /* Increment preservation count */
    ++blk->refCount;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ReleaseData()
 *
 *  Decreases the usage count for a piece of data that was registered
 *  previously via Itcl_PreserveData().  After Itcl_EventuallyFree()
 *  is called and the usage count reaches zero, the data is
 *  automatically freed.
 * ------------------------------------------------------------------------
 */
void
Itcl_ReleaseData(
    ClientData cdata)      /* data to be released */
{
    PresMemoryPrefix *blk;
    Tcl_FreeProc *freeProc;

    if (cdata == NULL) {
        return;
    }

    /* Itcl memory block to ckalloc block */
    blk = ((PresMemoryPrefix *)cdata)-1;

    /* Usage sanity check */
    assert(blk->refCount != 0); /* must call Itcl_PreserveData() first */
    assert(blk->freeProc);	/* must call Itcl_EventuallyFree() first */

    /* Decrement preservation count */
    if (--blk->refCount) {
	return;
    }

    /* Free cdata now */
    freeProc = blk->freeProc;
    blk->freeProc = NULL;
    freeProc(cdata);
}

    /*
/*
     *  If the clientData value is NULL, do nothing.
     */
    if (cdata == NULL) {
        return;
    }
    Tcl_Release(cdata);
    return;
 * ------------------------------------------------------------------------
 * Itcl_Alloc()
 *
 *	Allocate preservable memory. In opposite to ckalloc the result can be
 *	supplied to preservation facilities of Itcl (Itcl_PreserveData).
 *
 * Results:
 *	Pointer to new allocated memory.
 * ------------------------------------------------------------------------
 */
void * Itcl_Alloc(
    size_t size)	/* Size of memory to allocate */
{
    size_t numBytes;
    PresMemoryPrefix *blk;

    /* The ckalloc() in Tcl 8 can alloc at most UINT_MAX bytes */
    assert (size <= UINT_MAX - sizeof(PresMemoryPrefix));
    numBytes = size + sizeof(PresMemoryPrefix);

    /* This will panic on allocation failure. No need to check return value. */
    blk = (PresMemoryPrefix *)ckalloc(numBytes);

    /* Itcl_Alloc defined to zero-init memory it allocates */
    memset(blk, 0, numBytes);

    /* ckalloc block to Itcl memory block */
    return blk+1;
}
/*
 * ------------------------------------------------------------------------
 * ItclFree()
 *
 *	Release memory allocated by Itcl_Alloc() that was never preserved.
 *
 * Results:
 *	None.
 *
 * ------------------------------------------------------------------------
 */
void Itcl_Free(void *ptr) {
    PresMemoryPrefix *blk;
    
    if (ptr == NULL) {
	return;
    }
    /* Itcl memory block to ckalloc block */
    blk = ((PresMemoryPrefix *)ptr)-1;

    assert(blk->refCount == 0); /* it should be not preserved */
    assert(blk->freeProc == NULL); /* it should be released */
    ckfree(blk);
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_SaveInterpState()
 *
 *  Takes a snapshot of the current result state of the interpreter.