diff -Nru itcl4-4.1.2/ChangeLog itcl4-4.2.0/ChangeLog --- itcl4-4.1.2/ChangeLog 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/ChangeLog 2019-10-04 16:02:02.000000000 +0000 @@ -61,7 +61,7 @@ tracker. 2014-02-18 Arnulf P. Wiedemann * generic/itclResolve.c: - * generic/itclObject.c: fix for upvar problem (SF bug #187) in + * generic/itclObject.c: fix for upvar problem (SF bug #187) in splitting up the trace handlers for this, win, type, self and selfns. Also doing traces for linked variables to one of these. 2014-02-16 Arnulf P. Wiedemann @@ -291,7 +291,7 @@ * itcl/generic/itcl2TclOO.c (Itcl_NRRunCallbacks): Tcl's [Patch 3072080] (a saner NRE): TclNRRunCallbacks lost one - argument. + argument. 2010-08-22 Arnulf P.Wiedemann * itclInt.h, itclObject.c, itclInfo.c: fix for BiInfoHeritageCmd @@ -317,7 +317,7 @@ * itcl2Tcloo.h: fix for SF bug #2993648 * itclBuiltin.c: added an empty line for beautifying * itclCmd.c: in Itcl_IsObjectCmd if in constructor use the correct ioPtr - * itclObject.c: in Itcl_ObjectIsa check for contextIoPtr == NULL + * itclObject.c: in Itcl_ObjectIsa check for contextIoPtr == NULL to avoid segmentation violation 2010-04-21 Arnulf P.Wiedemann * itclCmd.c: Add missing Tcl_DStringFree for [itcl Bug 2983809] @@ -326,7 +326,7 @@ * itclParse.c: * itclResolve.c: - * itclParse.c: better error message when using: public mthod ... + * itclParse.c: better error message when using: public mthod ... instead of public method ... 2010-04-08 Don Porter * itclInt.h: Add #ifdef guards to attempt inclusion of @@ -393,12 +393,12 @@ NRE calling 2009-10-23 Arnulf P. Wiedemann - * itclMigrate2TclCore.c: added Itcl_GetUplevelCallFrame and + * itclMigrate2TclCore.c: added Itcl_GetUplevelCallFrame and Itcl_ActivateCallFrame functions same as in Itcl3.4. They are needed to call the itk_component command with the suitable call frame as this is needed for access to the - proc local vars. This was the fix for SF + proc local vars. This was the fix for SF bug #2840994 * itclStubInit.c: * itcl.decls: @@ -478,7 +478,7 @@ 2008-02-21 Arnulf P. Wiedemann * fix for SF bug 2595708 itclParse.c and itclBuiltin.c - * fix for problem with scope command path reported by + * fix for problem with scope command path reported by * Harald Krummeck on c.l.t ItclCmd.c 2008-02-02 Arnulf P. Wiedemann * generic/itcl.h configure.in: @@ -504,7 +504,7 @@ here are similar funtions to itclWidget.tcl for use by ::itcl::extendedclass - * generic/itclUtil.c: malloc.h include now bracketed with + * generic/itclUtil.c: malloc.h include now bracketed with #ifdef ITCL_PRESERVE_DEBUG as it is only used for debugging. I have to look for a solution using memory.h as a portable version, but @@ -514,18 +514,18 @@ necessary, as im am checking stuff done by ckalloc and ckfree, so these cannot be used. 2009-01-15 David Gravereaux - * generic/itcl2TclOO.h: More cleanups changing the last of the - * generic/itclClass.c: 'EXTERN' macros to just be 'extern' as we - * win/.cvsignore: aren't importing the declaration, just - * win/itcl.rc: sharing it internally. This caused warnings - * win/makefile.vc: on windows during the link stage as it was - * win/nmakehlp.c: getting confused about 'why are you + * generic/itcl2TclOO.h: More cleanups changing the last of the + * generic/itclClass.c: 'EXTERN' macros to just be 'extern' as we + * win/.cvsignore: aren't importing the declaration, just + * win/itcl.rc: sharing it internally. This caused warnings + * win/makefile.vc: on windows during the link stage as it was + * win/nmakehlp.c: getting confused about 'why are you * win/rules.vc: importing an internal function?' 2009-01-15 David Gravereaux * generic/itclMigrate2TclCore.h: All build errors squashed * generic/itclStubLib.c: * generic/itclTclIntStubFcn.h: - * win/makefile.vc: + * win/makefile.vc: 2009-01-14 David Gravereaux * generic/itclBase.c: * generic/itclBuiltin.c: @@ -543,7 +543,7 @@ * generic/itclTclIntStubsFcn.c: * win/makefile.vc: Changes to allow compiling on windows with - MSVC++. Double declaration of internal + MSVC++. Double declaration of internal functions not yet repaired. DOESN'T BUILD YET with makefile.vc. 2009-01-14 Daniel A. Steffen @@ -554,8 +554,8 @@ 2008-12-11 Arnulf P. Wiedemann * itcl-ng first beta release 4.0b1 2008-12-06 Arnulf P. Wiedemann - * built enhanced functions for chasing memory leaks in adding - * functionality to the functions available in Tcl core + * built enhanced functions for chasing memory leaks in adding + * functionality to the functions available in Tcl core * and fixed a lot of leaks of that class 2008-11-30 Arnulf P. Wiedemann * built functions for chasing memory leaks and fixed a lot of those diff -Nru itcl4-4.1.2/configure itcl4-4.2.0/configure --- itcl4-4.1.2/configure 2018-10-17 16:52:02.000000000 +0000 +++ itcl4-4.2.0/configure 2019-11-03 02:29:10.000000000 +0000 @@ -1,6 +1,6 @@ #! /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. @@ -577,8 +577,8 @@ # 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='' @@ -619,7 +619,6 @@ #endif" ac_subst_vars='LTLIBOBJS -LIBOBJS itcl_INCLUDE_SPEC itcl_SRC_DIR PATCHLEVEL @@ -650,8 +649,8 @@ CFLAGS_WARNING CFLAGS_OPTIMIZE CFLAGS_DEBUG +LIBOBJS RC -CELIB_DIR AR STUBS_BUILD SHARED_BUILD @@ -755,8 +754,6 @@ enable_64bit enable_64bit_vis enable_rpath -enable_wince -with_celib enable_symbols ' ac_precious_vars='build_alias @@ -1308,7 +1305,7 @@ # 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]... @@ -1369,7 +1366,7 @@ 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 @@ -1384,7 +1381,6 @@ --enable-64bit enable 64bit support (default: off) --enable-64bit-vis enable 64bit Sparc VIS support (default: off) --disable-rpath disable rpath support (default: on) - --enable-wince enable Win/CE support (where applicable) --enable-symbols build with debugging symbols (default: off) Optional Packages: @@ -1393,7 +1389,6 @@ --with-tcl directory containing tcl configuration (tclConfig.sh) --with-tclinclude directory containing the public Tcl header files - --with-celib=DIR use Windows/CE support library from DIR Some influential environment variables: CC C compiler command @@ -1471,7 +1466,7 @@ 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. @@ -1679,6 +1674,93 @@ } # ac_fn_c_try_link +# ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES +# ------------------------------------------------------- +# Tests whether HEADER exists, giving a warning if it cannot be compiled using +# the include files in INCLUDES and setting the cache variable VAR +# accordingly. +ac_fn_c_check_header_mongrel () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if eval \${$3+:} false; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +else + # Is the header compilable? +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 +$as_echo_n "checking $2 usability... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +#include <$2> +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_header_compiler=yes +else + ac_header_compiler=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 +$as_echo "$ac_header_compiler" >&6; } + +# Is the header present? +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 +$as_echo_n "checking $2 presence... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <$2> +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + ac_header_preproc=yes +else + ac_header_preproc=no +fi +rm -f conftest.err conftest.i conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 +$as_echo "$ac_header_preproc" >&6; } + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #(( + yes:no: ) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 +$as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} + ;; + no:yes:* ) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 +$as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 +$as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 +$as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 +$as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} + ;; +esac + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + eval "$3=\$ac_header_compiler" +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_header_mongrel + # ac_fn_c_check_func LINENO FUNC VAR # ---------------------------------- # Tests whether FUNC exists, setting the cache variable VAR accordingly @@ -1803,7 +1885,7 @@ 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 $@ @@ -2177,7 +2259,7 @@ fi case "`uname -s`" in - *win32*|*WIN32*|*MINGW32_*|*MINGW64_*) + *win32*|*WIN32*|*MINGW32_*|*MINGW64_*|*MSYS_*) # Extract the first word of "cygpath", so it can be a program name with args. set dummy cygpath; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 @@ -2297,6 +2379,9 @@ if test "`uname -s`" = "AIX" ; then tcl_cv_sys_version=AIX-`uname -v`.`uname -r` fi + if test "`uname -s`" = "NetBSD" -a -f /etc/debian_version ; then + tcl_cv_sys_version=NetBSD-Debian + fi fi fi @@ -2457,7 +2542,6 @@ for i in `ls -d ~/Library/Frameworks 2>/dev/null` \ `ls -d /Library/Frameworks 2>/dev/null` \ `ls -d /Network/Library/Frameworks 2>/dev/null` \ - `ls -d /System/Library/Frameworks 2>/dev/null` \ `ls -d /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/Library/Frameworks/Tcl.framework 2>/dev/null` \ `ls -d /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/Network/Library/Frameworks/Tcl.framework 2>/dev/null` \ `ls -d /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/System/Library/Frameworks/Tcl.framework 2>/dev/null` \ @@ -3418,7 +3502,8 @@ _ACEOF if ac_fn_c_try_compile "$LINENO"; then : - TEA_PLATFORM="unix" + # first test we've already retrieved platform (cross-compile), fallback to unix otherwise: + TEA_PLATFORM="${TEA_PLATFORM-unix}" CYGPATH=echo else @@ -5576,18 +5661,6 @@ that IS thread-enabled. It is recommended to use --enable-threads." >&2;} fi ;; - *) - if test "${TCL_THREADS}" = "1"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: - --enable-threads requested, but building against a Tcl that is NOT - thread-enabled. This is an OK configuration that will also run in - a thread-enabled core." >&5 -$as_echo "$as_me: WARNING: - --enable-threads requested, but building against a Tcl that is NOT - thread-enabled. This is an OK configuration that will also run in - a thread-enabled core." >&2;} - fi - ;; esac @@ -5859,24 +5932,6 @@ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $doRpath" >&5 $as_echo "$doRpath" >&6; } - # TEA specific: Cross-compiling options for Windows/CE builds? - - if test "${TEA_PLATFORM}" = windows; then : - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if Windows/CE build is requested" >&5 -$as_echo_n "checking if Windows/CE build is requested... " >&6; } - # Check whether --enable-wince was given. -if test "${enable_wince+set}" = set; then : - enableval=$enable_wince; doWince=$enableval -else - doWince=no -fi - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $doWince" >&5 -$as_echo "$doWince" >&6; } - -fi - # Set the variable "system" to hold the name and version number # for the system. @@ -5900,6 +5955,9 @@ if test "`uname -s`" = "AIX" ; then tcl_cv_sys_version=AIX-`uname -v`.`uname -r` fi + if test "`uname -s`" = "NetBSD" -a -f /etc/debian_version ; then + tcl_cv_sys_version=NetBSD-Debian + fi fi fi @@ -6078,124 +6136,6 @@ fi fi - if test "$doWince" != "no" ; then - if test "$do64bit" != "no" ; then - as_fn_error $? "Windows/CE and 64-bit builds incompatible" "$LINENO" 5 - fi - if test "$GCC" = "yes" ; then - as_fn_error $? "Windows/CE and GCC builds incompatible" "$LINENO" 5 - fi - - # First, look for one uninstalled. - # the alternative search directory is invoked by --with-celib - - if test x"${no_celib}" = x ; then - # we reset no_celib in case something fails here - no_celib=true - -# Check whether --with-celib was given. -if test "${with_celib+set}" = set; then : - withval=$with_celib; with_celibconfig=${withval} -fi - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Windows/CE celib directory" >&5 -$as_echo_n "checking for Windows/CE celib directory... " >&6; } - if ${ac_cv_c_celibconfig+:} false; then : - $as_echo_n "(cached) " >&6 -else - - # First check to see if --with-celibconfig was specified. - if test x"${with_celibconfig}" != x ; then - if test -d "${with_celibconfig}/inc" ; then - ac_cv_c_celibconfig=`(cd ${with_celibconfig}; pwd)` - else - as_fn_error $? "${with_celibconfig} directory doesn't contain inc directory" "$LINENO" 5 - fi - fi - - # then check for a celib library - if test x"${ac_cv_c_celibconfig}" = x ; then - for i in \ - ../celib-palm-3.0 \ - ../celib \ - ../../celib-palm-3.0 \ - ../../celib \ - `ls -dr ../celib-*3.[0-9]* 2>/dev/null` \ - ${srcdir}/../celib-palm-3.0 \ - ${srcdir}/../celib \ - `ls -dr ${srcdir}/../celib-*3.[0-9]* 2>/dev/null` \ - ; do - if test -d "$i/inc" ; then - ac_cv_c_celibconfig=`(cd $i; pwd)` - break - fi - done - fi - -fi - - if test x"${ac_cv_c_celibconfig}" = x ; then - as_fn_error $? "Cannot find celib support library directory" "$LINENO" 5 - else - no_celib= - CELIB_DIR=${ac_cv_c_celibconfig} - CELIB_DIR=`echo "$CELIB_DIR" | sed -e 's!\\\!/!g'` - { $as_echo "$as_me:${as_lineno-$LINENO}: result: found $CELIB_DIR" >&5 -$as_echo "found $CELIB_DIR" >&6; } - fi - fi - - # Set defaults for common evc4/PPC2003 setup - # Currently Tcl requires 300+, possibly 420+ for sockets - CEVERSION=420; # could be 211 300 301 400 420 ... - TARGETCPU=ARMV4; # could be ARMV4 ARM MIPS SH3 X86 ... - ARCH=ARM; # could be ARM MIPS X86EM ... - PLATFORM="Pocket PC 2003"; # or "Pocket PC 2002" - if test "$doWince" != "yes"; then - # If !yes then the user specified something - # Reset ARCH to allow user to skip specifying it - ARCH= - eval `echo $doWince | awk -F, '{ \ - if (length($1)) { printf "CEVERSION=\"%s\"\n", $1; \ - if ($1 < 400) { printf "PLATFORM=\"Pocket PC 2002\"\n" } }; \ - if (length($2)) { printf "TARGETCPU=\"%s\"\n", toupper($2) }; \ - if (length($3)) { printf "ARCH=\"%s\"\n", toupper($3) }; \ - if (length($4)) { printf "PLATFORM=\"%s\"\n", $4 }; \ - }'` - if test "x${ARCH}" = "x" ; then - ARCH=$TARGETCPU; - fi - fi - OSVERSION=WCE$CEVERSION; - if test "x${WCEROOT}" = "x" ; then - WCEROOT="C:/Program Files/Microsoft eMbedded C++ 4.0" - if test ! -d "${WCEROOT}" ; then - WCEROOT="C:/Program Files/Microsoft eMbedded Tools" - fi - fi - if test "x${SDKROOT}" = "x" ; then - SDKROOT="C:/Program Files/Windows CE Tools" - if test ! -d "${SDKROOT}" ; then - SDKROOT="C:/Windows CE Tools" - fi - fi - WCEROOT=`echo "$WCEROOT" | sed -e 's!\\\!/!g'` - SDKROOT=`echo "$SDKROOT" | sed -e 's!\\\!/!g'` - if test ! -d "${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}" \ - -o ! -d "${WCEROOT}/EVC/${OSVERSION}/bin"; then - as_fn_error $? "could not find PocketPC SDK or target compiler to enable WinCE mode $CEVERSION,$TARGETCPU,$ARCH,$PLATFORM" "$LINENO" 5 - doWince="no" - else - # We could PATH_NOSPACE these, but that's not important, - # as long as we quote them when used. - CEINCLUDE="${SDKROOT}/${OSVERSION}/${PLATFORM}/include" - if test -d "${CEINCLUDE}/${TARGETCPU}" ; then - CEINCLUDE="${CEINCLUDE}/${TARGETCPU}" - fi - CELIBPATH="${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}" - fi - fi - if test "$GCC" != "yes" ; then if test "${SHARED_BUILD}" = "0" ; then runtime=-MT @@ -6243,44 +6183,6 @@ done - elif test "$doWince" != "no" ; then - CEBINROOT="${WCEROOT}/EVC/${OSVERSION}/bin" - if test "${TARGETCPU}" = "X86"; then - CC="\"${CEBINROOT}/cl.exe\"" - else - CC="\"${CEBINROOT}/cl${ARCH}.exe\"" - fi - CFLAGS="$CFLAGS -I\"${CELIB_DIR}/inc\" -I\"${CEINCLUDE}\"" - RC="\"${WCEROOT}/Common/EVC/bin/rc.exe\"" - arch=`echo ${ARCH} | awk '{print tolower($0)}'` - defs="${ARCH} _${ARCH}_ ${arch} PALM_SIZE _MT _WINDOWS" - if test "${SHARED_BUILD}" = "1" ; then - # Static CE builds require static celib as well - defs="${defs} _DLL" - fi - for i in $defs ; do - -cat >>confdefs.h <<_ACEOF -#define $i 1 -_ACEOF - - done - -cat >>confdefs.h <<_ACEOF -#define _WIN32_WCE $CEVERSION -_ACEOF - - -cat >>confdefs.h <<_ACEOF -#define UNDER_CE $CEVERSION -_ACEOF - - CFLAGS_DEBUG="-nologo -Zi -Od" - CFLAGS_OPTIMIZE="-nologo -Ox" - lversion=`echo ${CEVERSION} | sed -e 's/\(.\)\(..\)/\1\.\2/'` - lflags="${lflags} -MACHINE:${ARCH} -LIBPATH:\"${CELIBPATH}\" -subsystem:windowsce,${lversion} -nologo" - LINKBIN="\"${CEBINROOT}/link.exe\"" - else RC="rc" lflags="${lflags} -nologo" @@ -6453,13 +6355,8 @@ # This essentially turns it all on. LDFLAGS_DEBUG="-debug -debugtype:cv" LDFLAGS_OPTIMIZE="-release" - if test "$doWince" != "no" ; then - LDFLAGS_CONSOLE="-link ${lflags}" - LDFLAGS_WINDOW=${LDFLAGS_CONSOLE} - else - LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}" - LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}" - fi + LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}" + LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}" fi SHLIB_SUFFIX=".dll" @@ -6468,7 +6365,7 @@ TCL_LIB_VERSIONS_OK=nodots ;; AIX-*) - if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes"; then : + if test "$GCC" != "yes"; then : # AIX requires the _r compiler when gcc isn't being used case "${CC}" in @@ -6595,6 +6492,13 @@ fi ;; + BSD/OS-2.1*|BSD/OS-3*) + SHLIB_CFLAGS="" + SHLIB_LD="shlicc -r" + SHLIB_SUFFIX=".so" + CC_SEARCH_FLAGS="" + LD_SEARCH_FLAGS="" + ;; BSD/OS-4.*) SHLIB_CFLAGS="-export-dynamic -fPIC" SHLIB_LD='${CC} -shared' @@ -6606,13 +6510,54 @@ CYGWIN_*) SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' - SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$@.a" SHLIB_SUFFIX=".dll" + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$@.a" + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Cygwin version of gcc" >&5 +$as_echo_n "checking for Cygwin version of gcc... " >&6; } +if ${ac_cv_cygwin+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #ifdef __CYGWIN__ + #error cygwin + #endif + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_cygwin=no +else + ac_cv_cygwin=yes +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cygwin" >&5 +$as_echo "$ac_cv_cygwin" >&6; } + if test "$ac_cv_cygwin" = "no"; then + as_fn_error $? "${CC} is not a cygwin compiler." "$LINENO" 5 + fi EXEEXT=".exe" do64bit_ok=yes CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; + dgux*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD='${CC} -G' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + CC_SEARCH_FLAGS="" + LD_SEARCH_FLAGS="" + ;; Haiku*) LDFLAGS="$LDFLAGS -Wl,--export-dynamic" SHLIB_CFLAGS="-fPIC" @@ -6671,10 +6616,6 @@ if test "`uname -m`" = ia64; then : SHLIB_SUFFIX=".so" - # Use newer C++ library for C++ extensions - #if test "$GCC" != "yes" ; then - # CPPFLAGS="-AA" - #fi else @@ -6725,6 +6666,8 @@ if test "$tcl_ok" = yes; then : + SHLIB_CFLAGS="+z" + SHLIB_LD="ld -b" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' @@ -6739,10 +6682,6 @@ else CFLAGS="$CFLAGS -z" - # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc - #CFLAGS="$CFLAGS +DAportable" - SHLIB_CFLAGS="+z" - SHLIB_LD="ld -b" fi @@ -6777,6 +6716,77 @@ fi fi ;; + HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) + SHLIB_SUFFIX=".sl" + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5 +$as_echo_n "checking for shl_load in -ldld... " >&6; } +if ${ac_cv_lib_dld_shl_load+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-ldld $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char shl_load (); +int +main () +{ +return shl_load (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_dld_shl_load=yes +else + ac_cv_lib_dld_shl_load=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5 +$as_echo "$ac_cv_lib_dld_shl_load" >&6; } +if test "x$ac_cv_lib_dld_shl_load" = xyes; then : + tcl_ok=yes +else + tcl_ok=no +fi + + if test "$tcl_ok" = yes; then : + + SHLIB_CFLAGS="+z" + SHLIB_LD="ld -b" + SHLIB_LD_LIBS="" + LDFLAGS="$LDFLAGS -Wl,-E" + CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' + LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' + LD_LIBRARY_PATH_VAR="SHLIB_PATH" + +fi ;; + IRIX-5.*) + SHLIB_CFLAGS="" + SHLIB_LD="ld -shared -rdata_shared" + SHLIB_SUFFIX=".so" + case " $LIBOBJS " in + *" mkstemp.$ac_objext "* ) ;; + *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" + ;; +esac + + if test $doRpath = yes; then : + + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' +fi + ;; IRIX-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" @@ -6937,14 +6947,10 @@ SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so${SHLIB_VERSION}' LDFLAGS="-Wl,-export-dynamic" CFLAGS_OPTIMIZE="-O2" - if test "${TCL_THREADS}" = "1"; then : - - # On OpenBSD: Compile with -pthread - # Don't link with -lpthread - LIBS=`echo $LIBS | sed s/-lpthread//` - CFLAGS="$CFLAGS -pthread" - -fi + # On OpenBSD: Compile with -pthread + # Don't link with -lpthread + LIBS=`echo $LIBS | sed s/-lpthread//` + CFLAGS="$CFLAGS -pthread" # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots @@ -6960,16 +6966,12 @@ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' fi LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - if test "${TCL_THREADS}" = "1"; then : - - # The -pthread needs to go in the CFLAGS, not LIBS - LIBS=`echo $LIBS | sed s/-pthread//` - CFLAGS="$CFLAGS -pthread" - LDFLAGS="$LDFLAGS -pthread" - -fi + # The -pthread needs to go in the CFLAGS, not LIBS + LIBS=`echo $LIBS | sed s/-pthread//` + CFLAGS="$CFLAGS -pthread" + LDFLAGS="$LDFLAGS -pthread" ;; - FreeBSD-*) + DragonFly-*|FreeBSD-*) # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" @@ -6981,13 +6983,10 @@ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' fi - if test "${TCL_THREADS}" = "1"; then : - - # The -pthread needs to go in the LDFLAGS, not LIBS - LIBS=`echo $LIBS | sed s/-pthread//` - CFLAGS="$CFLAGS $PTHREAD_CFLAGS" - LDFLAGS="$LDFLAGS $PTHREAD_LIBS" -fi + # The -pthread needs to go in the LDFLAGS, not LIBS + LIBS=`echo $LIBS | sed s/-pthread//` + CFLAGS="$CFLAGS $PTHREAD_CFLAGS" + LDFLAGS="$LDFLAGS $PTHREAD_LIBS" case $system in FreeBSD-3.*) # Version numbers are dot-stripped by system policy. @@ -7143,12 +7142,6 @@ vers=`echo ${PACKAGE_VERSION} | sed -e 's/^\([0-9]\{1,5\}\)\(\(\.[0-9]\{1,3\}\)\{0,2\}\).*$/\1\2/p' -e d` SHLIB_LD="${SHLIB_LD} -current_version ${vers:-0} -compatibility_version ${vers:-0}" SHLIB_SUFFIX=".dylib" - # Don't use -prebind when building for Mac OS X 10.4 or later only: - if test "`echo "${MACOSX_DEPLOYMENT_TARGET}" | awk -F '10\\.' '{print int($2)}'`" -lt 4 -a \ - "`echo "${CPPFLAGS}" | awk -F '-mmacosx-version-min=10\\.' '{print int($2)}'`" -lt 4; then : - - LDFLAGS="$LDFLAGS -prebind" -fi LDFLAGS="$LDFLAGS -headerpad_max_install_names" { $as_echo "$as_me:${as_lineno-$LINENO}: checking if ld accepts -search_paths_first flag" >&5 $as_echo_n "checking if ld accepts -search_paths_first flag... " >&6; } @@ -7322,21 +7315,17 @@ CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee" fi # see pthread_intro(3) for pthread support on osf1, k.furukawa - if test "${TCL_THREADS}" = 1; then : - - CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" - CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" - LIBS=`echo $LIBS | sed s/-lpthreads//` - if test "$GCC" = yes; then : + CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" + CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" + LIBS=`echo $LIBS | sed s/-lpthreads//` + if test "$GCC" = yes; then : - LIBS="$LIBS -lpthread -lmach -lexc" + LIBS="$LIBS -lpthread -lmach -lexc" else - CFLAGS="$CFLAGS -pthread" - LDFLAGS="$LDFLAGS -pthread" - -fi + CFLAGS="$CFLAGS -pthread" + LDFLAGS="$LDFLAGS -pthread" fi ;; @@ -7603,9 +7592,9 @@ case $system in AIX-*) ;; BSD/OS*) ;; - CYGWIN_*|MINGW32_*|MINGW64_*) ;; + CYGWIN_*|MINGW32_*|MINGW64_*|MSYS_*) ;; IRIX*) ;; - NetBSD-*|FreeBSD-*|OpenBSD-*) ;; + NetBSD-*|DragonFly-*|FreeBSD-*|OpenBSD-*) ;; Darwin-*) ;; SCO_SV-3.2*) ;; windows) ;; @@ -7808,6 +7797,15 @@ fi + ac_fn_c_check_header_mongrel "$LINENO" "stdbool.h" "ac_cv_header_stdbool_h" "$ac_includes_default" +if test "x$ac_cv_header_stdbool_h" = xyes; then : + +$as_echo "#define HAVE_STDBOOL_H 1" >>confdefs.h + +fi + + + @@ -8001,7 +7999,7 @@ tcl_type_64bit="long long" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - # See if we should use long anyway Note that we substitute in the + # See if we could use long anyway Note that we substitute in the # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... cat confdefs.h - <<_ACEOF >conftest.$ac_ext @@ -8027,8 +8025,8 @@ $as_echo "#define TCL_WIDE_INT_IS_LONG 1" >>confdefs.h - { $as_echo "$as_me:${as_lineno-$LINENO}: result: using long" >&5 -$as_echo "using long" >&6; } + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } elif test "${tcl_cv_type_64bit}" = "__int64" \ -a "${TEA_PLATFORM}" = "windows" ; then # TEA specific: We actually want to use the default tcl.h checks in @@ -8078,6 +8076,40 @@ fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for DIR64" >&5 +$as_echo_n "checking for DIR64... " >&6; } +if ${tcl_cv_DIR64+:} false; then : + $as_echo_n "(cached) " >&6 +else + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +int +main () +{ +struct dirent64 *p; DIR64 d = opendir64("."); + p = readdir64(d); rewinddir64(d); closedir64(d); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + tcl_cv_DIR64=yes +else + tcl_cv_DIR64=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_DIR64" >&5 +$as_echo "$tcl_cv_DIR64" >&6; } + if test "x${tcl_cv_DIR64}" = "xyes" ; then + +$as_echo "#define HAVE_DIR64 1" >>confdefs.h + + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for struct stat64" >&5 $as_echo_n "checking for struct stat64... " >&6; } if ${tcl_cv_struct_stat64+:} false; then : @@ -9031,7 +9063,7 @@ # 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 @@ -9084,7 +9116,7 @@ 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\\" diff -Nru itcl4-4.1.2/configure.ac itcl4-4.2.0/configure.ac --- itcl4-4.1.2/configure.ac 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/configure.ac 2019-10-04 16:02:02.000000000 +0000 @@ -19,7 +19,7 @@ # 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. @@ -223,7 +223,7 @@ for tcl_cv_intptr_t in "int" "long" "long long" none; do if test "$tcl_cv_intptr_t" != none; then AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], - [[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])], + [[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])], [tcl_ok=yes], [tcl_ok=no]) test "$tcl_ok" = yes && break; fi done]) diff -Nru itcl4-4.1.2/debian/changelog itcl4-4.2.0/debian/changelog --- itcl4-4.1.2/debian/changelog 2018-10-22 12:44:30.000000000 +0000 +++ itcl4-4.2.0/debian/changelog 2019-11-06 11:06:03.000000000 +0000 @@ -1,3 +1,11 @@ +itcl4 (4.2.0-1) unstable; urgency=medium + + * New upstream release. + * Bump standards version to 4.4.1. + * Fix the tcl-itcl4.symbols file. + + -- Sergei Golovan Wed, 06 Nov 2019 14:06:03 +0300 + itcl4 (4.1.2-1) unstable; urgency=medium * New upstream release. diff -Nru itcl4-4.1.2/debian/control itcl4-4.2.0/debian/control --- itcl4-4.1.2/debian/control 2018-10-22 12:44:30.000000000 +0000 +++ itcl4-4.2.0/debian/control 2019-11-06 11:06:03.000000000 +0000 @@ -4,7 +4,7 @@ Maintainer: Debian Tcl/Tk Packagers Uploaders: Sergei Golovan Build-Depends: debhelper (>= 10.0.0), tcl-dev -Standards-Version: 4.2.0 +Standards-Version: 4.4.1 Homepage: http://incrtcl.sourceforge.net/ Vcs-Browser: https://salsa.debian.org/tcltk-team/itcl4 Vcs-Git: https://salsa.debian.org/tcltk-team/itcl4.git diff -Nru itcl4-4.1.2/debian/tcl-itcl4.symbols itcl4-4.2.0/debian/tcl-itcl4.symbols --- itcl4-4.1.2/debian/tcl-itcl4.symbols 2018-10-22 12:44:30.000000000 +0000 +++ itcl4-4.2.0/debian/tcl-itcl4.symbols 2019-11-06 11:06:03.000000000 +0000 @@ -1,4 +1,4 @@ libitcl4.so tcl-itcl4 #MINVER# - ItclFreeMemberCode@Base 4.1.2 +#MISSING: 4.2.0# ItclFreeMemberCode@Base 4.1.2 Itcl_Init@Base 4.0.0 Itcl_SafeInit@Base 4.0.0 diff -Nru itcl4-4.1.2/debian/watch itcl4-4.2.0/debian/watch --- itcl4-4.1.2/debian/watch 1970-01-01 00:00:00.000000000 +0000 +++ itcl4-4.2.0/debian/watch 2019-11-06 11:06:03.000000000 +0000 @@ -0,0 +1,6 @@ +# Watch control file for uscan + +# Compulsory line, this is a version 3 file +version=3 + +http://sf.net/tcl/itcl([\d.]*)\.tar\.gz diff -Nru itcl4-4.1.2/doc/class.n itcl4-4.2.0/doc/class.n --- itcl4-4.1.2/doc/class.n 2013-11-12 13:33:55.000000000 +0000 +++ itcl4-4.2.0/doc/class.n 2019-11-03 02:24:15.000000000 +0000 @@ -381,16 +381,27 @@ and the body. Flags can be used to request specific elements from this list. .TP -\fIobjName \fBinfo variable\fR ?\fIvarName\fR? ?\fB-protection\fR? ?\fB-type\fR? ?\fB-name\fR? ?\fB-init\fR? ?\fB-value\fR? ?\fB-config\fR? +\fIobjName \fBinfo variable\fR ?\fIvarName\fR? ?\fB-protection\fR? ?\fB-type\fR? ?\fB-name\fR? ?\fB-init\fR? ?\fB-value\fR? ?\fB-config\fR? ?\fB-scope\fR? . With no arguments, this command returns a list of all object-specific variables and common data members. If \fIvarName\fR is specified, it -returns information for a specific data member. If no flags are -specified, this command returns a list with the following elements: the -protection level, the type (variable/common), the qualified name, the -initial value, and the current value. If \fIvarName\fR is a public -variable, the "config" code is included on this list. Flags can be -used to request specific elements from this list. +returns information for a specific data member. +Flags can be specified with \fIvarName\fR in an arbitrary order. +The result is a list of the specific information in exactly the +same order as the flags are specified. + +If no flags are given, this command returns a list +as if the followings flags have been specified: +.IP +\fB-protection\fR \fB-type\fR \fB-name\fR \fB-init\fR \fB-value\fR ?\fB-config\fR? + +The \fB-config\fR result is only present if \fIvarName\fR is a public +variable. It contains the code that is executed at initialization +of \fIvarName\fR. The \fB-scope\fR flag gives the namespace context +of \fIvarName\fR. Herewith the variable can be accessed from outside +the object like any other variable. It is similar to the result of +the \fBitcl::scope\fR command. + .RE .SH "CHAINING METHODS/PROCS" .PP @@ -407,7 +418,7 @@ if {$crumbs > 50} { error "== FIRE! FIRE! ==" } - set crumbs [expr $crumbs+4*$nslices] + set crumbs [expr {$crumbs+4*$nslices}] } method clean {} { set crumbs 0 diff -Nru itcl4-4.1.2/doc/ensemble.n itcl4-4.2.0/doc/ensemble.n --- itcl4-4.1.2/doc/ensemble.n 2013-11-12 13:33:55.000000000 +0000 +++ itcl4-4.2.0/doc/ensemble.n 2019-10-04 16:02:02.000000000 +0000 @@ -3,7 +3,7 @@ '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH ensemble n 3.0 itcl "[incr\ Tcl]" .so man.macros .BS diff -Nru itcl4-4.1.2/doc/is.n itcl4-4.2.0/doc/is.n --- itcl4-4.1.2/doc/is.n 2013-11-12 13:33:55.000000000 +0000 +++ itcl4-4.2.0/doc/is.n 2019-10-04 16:02:02.000000000 +0000 @@ -33,7 +33,7 @@ .PP The fully qualified name of the class needs to be given as the \fIcommand\fR argument. So, if a class resides in a namespace, then the namespace needs to -be specified as well. So, if a class \fBC\fR resides in a namespace \fBN\fR, then +be specified as well. So, if a class \fBC\fR resides in a namespace \fBN\fR, then the command should be called like: .PP .CS diff -Nru itcl4-4.1.2/doc/itcldelegate.n itcl4-4.2.0/doc/itcldelegate.n --- itcl4-4.1.2/doc/itcldelegate.n 2013-11-12 13:33:55.000000000 +0000 +++ itcl4-4.2.0/doc/itcldelegate.n 2019-10-04 16:02:02.000000000 +0000 @@ -64,7 +64,7 @@ delegate method wagtail to tail as "wag briskly" .CE .PP -A method cannot be both locally defined and delegated. +A method cannot be both locally defined and delegated. .RE .TP \fBdelegate method \fImethodName\fR ?\fBto \fIcomponentName\fR? \fBusing \fIpattern\fR @@ -85,7 +85,7 @@ delegate method wag to tail using "%c %m" .CE .PP -Each element of the list becomes a single element of the delegated command +Each element of the list becomes a single element of the delegated command --it is never reparsed as a string. .PP Substitutions: @@ -97,7 +97,7 @@ .TP \fB%c\fR . -This is replaced with the named component's command. +This is replaced with the named component's command. .TP \fB%j\fR . @@ -120,11 +120,11 @@ .TP \fB%s\fR . -This is replaced with the name of the instance command. +This is replaced with the name of the instance command. .TP \fB%t\fR . -This is replaced with the fully qualified type name. +This is replaced with the fully qualified type name. .TP \fB%w\fR . @@ -150,7 +150,7 @@ .CE .PP This implicitly defines the method tail whose subcommands will be -delegated to the tail component. +delegated to the tail component. .PP The definitions for \fBdelegate proc\fR ... are the same as for method, the only difference being, that this is for procs. diff -Nru itcl4-4.1.2/doc/itclextendedclass.n itcl4-4.2.0/doc/itclextendedclass.n --- itcl4-4.1.2/doc/itclextendedclass.n 2013-11-12 13:33:55.000000000 +0000 +++ itcl4-4.2.0/doc/itclextendedclass.n 2019-10-04 16:02:02.000000000 +0000 @@ -420,7 +420,7 @@ if {$crumbs > 50} { error "== FIRE! FIRE! ==" } - set crumbs [expr $crumbs+4*$nslices] + set crumbs [expr {$crumbs+4*$nslices}] } method clean {} { set crumbs 0 diff -Nru itcl4-4.1.2/doc/itcloption.n itcl4-4.2.0/doc/itcloption.n --- itcl4-4.1.2/doc/itcloption.n 2013-11-12 13:33:55.000000000 +0000 +++ itcl4-4.2.0/doc/itcloption.n 2019-10-04 16:02:02.000000000 +0000 @@ -67,12 +67,12 @@ \fB-default\fI defvalue\fR . Defines the option's default value; the option's default value will be "" -otherwise. +otherwise. .TP \fB-readonly\fR . The option is handled read-only -- it can only be set using configure at -creation time, i.e., in the type's constructor. +creation time, i.e., in the type's constructor. .TP \fB-cgetmethod\fI methodName\fR . @@ -91,7 +91,7 @@ } .CE .PP -Note that it's possible for any number of options to share a -cgetmethod. +Note that it's possible for any number of options to share a -cgetmethod. .RE .TP \fB-cgetmethodvar\fI varName\fR @@ -119,7 +119,7 @@ } .CE .PP -Note that it's possible for any number of options to share a single -configuremethod. +Note that it's possible for any number of options to share a single -configuremethod. .RE .TP \fB-configuremethodvar\fI varName\fR @@ -148,7 +148,7 @@ } .CE .PP -Note that it's possible for any number of options to share a single -validatemethod. +Note that it's possible for any number of options to share a single -validatemethod. .RE .TP \fB-validatemethodvar\fI varName\fR diff -Nru itcl4-4.1.2/doc/itclwidget.n itcl4-4.2.0/doc/itclwidget.n --- itcl4-4.1.2/doc/itclwidget.n 2014-06-03 12:28:46.000000000 +0000 +++ itcl4-4.2.0/doc/itclwidget.n 2019-10-04 16:02:02.000000000 +0000 @@ -422,7 +422,7 @@ if {$crumbs > 50} { error "== FIRE! FIRE! ==" } - set crumbs [expr $crumbs+4*$nslices] + set crumbs [expr {$crumbs+4*$nslices}] } method clean {} { set crumbs 0 diff -Nru itcl4-4.1.2/doc/Preserve.3 itcl4-4.2.0/doc/Preserve.3 --- itcl4-4.1.2/doc/Preserve.3 2013-11-12 13:33:55.000000000 +0000 +++ itcl4-4.2.0/doc/Preserve.3 2019-11-03 02:27:18.000000000 +0000 @@ -9,29 +9,74 @@ .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 \fR +void * +\fBItcl_Alloc\fR(\fIsize\fR) + +void +\fBItcl_PreserveData\fR(\fIptr\fR) + void -\fBItcl_PreserveData\fR(\fIcdata\fR) +\fBItcl_ReleaseData\fR(\fIptr\fR) void -\fBItcl_ReleaseData\fR(\fIcdata\fR) +\fBItcl_EventuallyFree\fR(\fIptr, fproc\fR) void -\fBItcl_EventuallyFree\fR(\fIcdata, fproc\fR) +\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. All \fIsize\fR bytes are +initialized to zero. +.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\fR 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 diff -Nru itcl4-4.1.2/doc/scope.n itcl4-4.2.0/doc/scope.n --- itcl4-4.1.2/doc/scope.n 2017-12-08 13:09:27.000000000 +0000 +++ itcl4-4.2.0/doc/scope.n 2019-10-04 16:02:02.000000000 +0000 @@ -19,7 +19,7 @@ Creates a scoped value for the specified \fIname\fR, which must be a variable name. If the \fIname\fR is an instance variable, then the scope command returns a name which will resolve in any -context as an instance variable belonging to \fIobject\fR. +context as an instance variable belonging to \fIobject\fR. The precise format of this name is an internal detail to Itcl. Use of such a scoped value makes it possible to use instance variables in conjunction with widgets. For example, if you diff -Nru itcl4-4.1.2/generic/clientData itcl4-4.2.0/generic/clientData --- itcl4-4.1.2/generic/clientData 2013-03-14 16:30:36.000000000 +0000 +++ itcl4-4.2.0/generic/clientData 1970-01-01 00:00:00.000000000 +0000 @@ -1,16 +0,0 @@ -itcl2TclOO.c: framePtr->clientData = NULL; -itcl2TclOO.c: framePtr->objc = objc; -itcl2TclOO.c: framePtr->objv = objv; -itcl2TclOO.c: framePtr->procPtr = procPtr; -itcl2TclOO.c: if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { -itcl2TclOO.c: contextPtr = framePtr->clientData; -itcl2TclOO.c: if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { -itclMigrate2TclCore.c: framePtr->isProcCallFrame |= FRAME_HAS_RESOLVER; -itclMigrate2TclCore.c: framePtr->resolvePtr = resolvePtr; -itclMigrate2TclCore.c: framePtr = framePtr->callerVarPtr; -itclMigrate2TclCore.c: framePtr = framePtr->callerVarPtr; -itclMigrate2TclCore.c: return (Tcl_Namespace *)framePtr->nsPtr; -itclMigrate2TclCore.c: return framePtr->clientData; -itclMigrate2TclCore.c: ((Interp *)interp)->framePtr->nsPtr = (Namespace *)nsPtr; -itclMigrate2TclCore.c: return ((Interp *)interp)->framePtr->objc; -itclMigrate2TclCore.c: return ((Interp *)interp)->framePtr->objv; diff -Nru itcl4-4.1.2/generic/itcl2TclOO.c itcl4-4.2.0/generic/itcl2TclOO.c --- itcl4-4.1.2/generic/itcl2TclOO.c 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/generic/itcl2TclOO.c 2019-10-04 16:02:02.000000000 +0000 @@ -11,6 +11,9 @@ #include #include +#undef FOREACH_HASH_DECLS +#undef FOREACH_HASH +#undef FOREACH_HASH_VALUE #include "itclInt.h" void * @@ -25,18 +28,18 @@ Tcl_Interp *interp, void *rootPtr) { - return TclNRRunCallbacks(interp, TCL_OK, rootPtr); + return TclNRRunCallbacks(interp, TCL_OK, (NRE_callback*)rootPtr); } static int CallFinalizePMCall( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { - Tcl_Namespace *nsPtr = data[0]; + Tcl_Namespace *nsPtr = (Tcl_Namespace *)data[0]; TclOO_PostCallProc *postCallProc = (TclOO_PostCallProc *)data[1]; - ClientData clientData = data[2]; + void *clientData = data[2]; /* * Give the post-call callback a chance to do some cleanup. Note that at @@ -48,12 +51,12 @@ static int FreeCommand( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { - Command *cmdPtr = data[0]; - Proc *procPtr = data[1]; + Command *cmdPtr = (Command *)data[0]; + Proc *procPtr = (Proc *)data[1]; ckfree(cmdPtr); procPtr->cmdPtr = NULL; @@ -77,7 +80,7 @@ int result; if (procPtr->cmdPtr == NULL) { - Command *cmdPtr = ckalloc(sizeof(Command)); + Command *cmdPtr = (Command *)ckalloc(sizeof(Command)); memset(cmdPtr, 0, sizeof(Command)); cmdPtr->nsPtr = (Namespace *) nsPtr; @@ -132,7 +135,7 @@ if (pmPtr->postCallProc) { Tcl_NRAddCallback(interp, CallFinalizePMCall, nsPtr, - (Tcl_NRPostProc *)pmPtr->postCallProc, pmPtr->clientData, NULL); + (void *)pmPtr->postCallProc, pmPtr->clientData, NULL); } return TclNRInterpProcCore(interp, namePtr, 1, pmPtr->errProc); @@ -142,7 +145,7 @@ int Itcl_InvokeProcedureMethod( - ClientData clientData, /* Pointer to some per-method context. */ + void *clientData, /* Pointer to some per-method context. */ Tcl_Interp *interp, int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments as actually seen. */ @@ -150,7 +153,7 @@ Tcl_Namespace *nsPtr; Method *mPtr; - mPtr = clientData; + mPtr = (Method *)clientData; if (mPtr->declaringClassPtr == NULL) { /* that is the case for typemethods */ nsPtr = mPtr->declaringObjectPtr->namespacePtr; @@ -159,16 +162,16 @@ } return Tcl_InvokeClassProcedureMethod(interp, mPtr->namePtr, nsPtr, - mPtr->clientData, objc, objv); + (ProcedureMethod *)mPtr->clientData, objc, objv); } static int FreeProcedureMethod( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { - ProcedureMethod *pmPtr = data[0]; + ProcedureMethod *pmPtr = (ProcedureMethod *)data[0]; ckfree(pmPtr); return result; } @@ -197,7 +200,7 @@ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments as actually seen. */ { - ProcedureMethod *pmPtr = ckalloc(sizeof(ProcedureMethod)); + ProcedureMethod *pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); memset(pmPtr, 0, sizeof(ProcedureMethod)); pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; @@ -225,7 +228,7 @@ int Itcl_PublicObjectCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, Tcl_Class clsPtr, int objc, @@ -256,7 +259,7 @@ TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, - ClientData clientData, + void *clientData, Tcl_Obj *nameObj, /* The name of the method, which may be NULL; * if so, up to caller to manage storage * (e.g., because it is a constructor or @@ -266,7 +269,7 @@ * to an empty list. */ Tcl_Obj *bodyObj, /* The body of the method, which must not be * NULL. */ - ClientData *clientData2) + void **clientData2) { Tcl_Method result; @@ -293,14 +296,14 @@ TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, - ClientData clientData, + void *clientData, Tcl_Obj *nameObj, /* The name of the method, which must not be * NULL. */ Tcl_Obj *argsObj, /* The formal argument list for the method, * which must not be NULL. */ Tcl_Obj *bodyObj, /* The body of the method, which must not be * NULL. */ - ClientData *clientData2) + void **clientData2) { return TclOONewProcInstanceMethodEx(interp, oPtr, preCallPtr, postCallPtr, errProc, clientData, nameObj, argsObj, bodyObj, @@ -349,7 +352,7 @@ int Itcl_SelfCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -364,7 +367,7 @@ return TCL_ERROR; } - contextPtr = framePtr->clientData; + contextPtr = (CallContext *)framePtr->clientData; if (objc == 1) { Tcl_SetObjResult(interp, Itcl_TclOOObjectName(interp, contextPtr->oPtr)); @@ -384,10 +387,3 @@ } return 1; } - -/* needed as work around for problem in Tcl 8.6.2 TclOO */ -void -Itcl_IncrObjectRefCount(Tcl_Object ptr) { - Object * oPtr = (Object *) ptr; - oPtr->refCount++; -} diff -Nru itcl4-4.1.2/generic/itcl2TclOO.h itcl4-4.2.0/generic/itcl2TclOO.h --- itcl4-4.1.2/generic/itcl2TclOO.h 2014-09-08 11:53:29.000000000 +0000 +++ itcl4-4.2.0/generic/itcl2TclOO.h 2019-10-04 16:02:02.000000000 +0000 @@ -31,4 +31,3 @@ Tcl_Obj *namePtr, Tcl_Proc *procPtr, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int Itcl_InvokeProcedureMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE void Itcl_IncrObjectRefCount(Tcl_Object ptr); diff -Nru itcl4-4.1.2/generic/itclBase.c itcl4-4.2.0/generic/itclBase.c --- itcl4-4.1.2/generic/itclBase.c 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/generic/itclBase.c 2019-11-03 02:24:15.000000000 +0000 @@ -13,18 +13,10 @@ #include #include "itclInt.h" -static Tcl_ObjCmdProc ItclFinishCmd; +static Tcl_NamespaceDeleteProc FreeItclObjectInfo; static Tcl_ObjCmdProc ItclSetHullWindowName; static Tcl_ObjCmdProc ItclCheckSetItclHull; -#ifdef OBJ_REF_COUNT_DEBUG -static Tcl_ObjCmdProc ItclDumpRefCountInfo; -#endif - -#ifdef ITCL_PRESERVE_DEBUG -static Tcl_ObjCmdProc ItclDumpPreserveInfo; -#endif - MODULE_SCOPE const ItclStubs itclStubs; static int Initialize(Tcl_Interp *interp); @@ -103,39 +95,29 @@ #define ITCL_IS_ENSEMBLE 0x1 -typedef struct ItclCmdsInfo { - const char *name; - int flags; -} ItclCmdsInfo; -static ItclCmdsInfo itclCmds [] = { - { "::itcl::class", 0}, - { "::itcl::find", ITCL_IS_ENSEMBLE}, - { "::itcl::delete", ITCL_IS_ENSEMBLE}, - { "::itcl::is", ITCL_IS_ENSEMBLE}, - { "::itcl::filter", ITCL_IS_ENSEMBLE}, - { "::itcl::forward", ITCL_IS_ENSEMBLE}, - { "::itcl::import::stub", ITCL_IS_ENSEMBLE}, - { "::itcl::mixin", ITCL_IS_ENSEMBLE}, - { "::itcl::parser::delegate", ITCL_IS_ENSEMBLE}, - { "::itcl::type", 0}, - { "::itcl::widget", 0}, - { "::itcl::widgetadaptor", 0}, - { "::itcl::nwidget", 0}, - { "::itcl::addoption", 0}, - { "::itcl::addobjectoption", 0}, - { "::itcl::adddelegatedoption", 0}, - { "::itcl::adddelegatedmethod", 0}, - { "::itcl::addcomponent", 0}, - { "::itcl::setcomponent", 0}, - { "::itcl::extendedclass", 0}, - { "::itcl::genericclass", 0}, - { "::itcl::parser::delegate", ITCL_IS_ENSEMBLE}, - { NULL, 0}, -}; #ifdef ITCL_DEBUG_C_INTERFACE extern void RegisterDebugCFunctions( Tcl_Interp * interp); #endif +static Tcl_ObjectMetadataDeleteProc Demolition; + +static const Tcl_ObjectMetadataType canary = { + TCL_OO_METADATA_VERSION_CURRENT, + "Itcl Foundations", + Demolition, + NULL +}; + +void +Demolition( + void *clientData) +{ + ItclObjectInfo *infoPtr = (ItclObjectInfo *)clientData; + + infoPtr->clazzObjectPtr = NULL; + infoPtr->clazzClassPtr = NULL; +} + static const Tcl_ObjectMetadataType objMDT = { TCL_OO_METADATA_VERSION_CURRENT, "ItclObject", @@ -155,14 +137,14 @@ static int RootCallProc( - ClientData clientData, + void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Tcl_Object oPtr = Tcl_ObjectContextObject(context); - ItclObject *ioPtr = Tcl_ObjectGetMetadata(oPtr, &objMDT); + ItclObject *ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, &objMDT); ItclRootMethodProc *proc = (ItclRootMethodProc *)clientData; return (*proc)(ioPtr, interp, objc, objv); @@ -170,24 +152,6 @@ /* * ------------------------------------------------------------------------ - * FreeItclObjectInfo() - * - * called when an interp is deleted to free up memory - * - * ------------------------------------------------------------------------ - */ -static void -FreeItclObjectInfo( - ClientData clientData) -{ - ItclObjectInfo *infoPtr; - - infoPtr = (ItclObjectInfo *)clientData; - ItclFinishCmd(infoPtr, infoPtr->interp, 0, NULL); -} - -/* - * ------------------------------------------------------------------------ * Initialize() * * that is the starting point when loading the library @@ -196,10 +160,6 @@ * ------------------------------------------------------------------------ */ -#ifdef NEW_PROTO_RESOLVER -int ItclVarsAndCommandResolveInit(Tcl_Interp *interp); -#endif - static int Initialize ( Tcl_Interp *interp) @@ -212,6 +172,7 @@ char *res_option; int opt; int isNew; + Tcl_Class tclCls; Tcl_Object clazzObjectPtr, root; Tcl_Obj *objPtr, *resPtr; @@ -224,45 +185,36 @@ return TCL_ERROR; } - infoPtr = (ItclObjectInfo*)ckalloc(sizeof(ItclObjectInfo)); + objPtr = Tcl_NewStringObj("::oo::class", -1); + Tcl_IncrRefCount(objPtr); + clazzObjectPtr = Tcl_GetObjectFromObj(interp, objPtr); + if (!clazzObjectPtr || !(tclCls = Tcl_GetObjectAsClass(clazzObjectPtr))) { + Tcl_DecrRefCount(objPtr); + return TCL_ERROR; + } + Tcl_DecrRefCount(objPtr); + + 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", + nsPtr = Tcl_CreateNamespace(interp, ITCL_INTDICTS_NAMESPACE, NULL, NULL); if (nsPtr == NULL) { - ckfree(infoPtr); + Itcl_Free(infoPtr); Tcl_Panic("Itcl: cannot create namespace: \"%s::internal::dicts\" \n", ITCL_NAMESPACE); } - Tcl_CreateObjCommand(interp, ITCL_NAMESPACE"::finish", ItclFinishCmd, - NULL, NULL); - - /* for debugging only !!! */ -#ifdef OBJ_REF_COUNT_DEBUG - Tcl_CreateObjCommand(interp, - ITCL_NAMESPACE"::dumprefcountinfo", - ItclDumpRefCountInfo, NULL, NULL); -#endif - -#ifdef ITCL_PRESERVE_DEBUG - Tcl_CreateObjCommand(interp, - ITCL_NAMESPACE"::dumppreserveinfo", - ItclDumpPreserveInfo, NULL, NULL); -#endif - /* END for debugging only !!! */ - /* * 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)); @@ -282,6 +234,7 @@ Tcl_InitHashTable(&infoPtr->instances, TCL_STRING_KEYS); Tcl_InitHashTable(&infoPtr->frameContext, TCL_ONE_WORD_KEYS); Tcl_InitObjHashTable(&infoPtr->classTypes); + infoPtr->ensembleInfo = (EnsembleInfo *)ckalloc(sizeof(EnsembleInfo)); memset(infoPtr->ensembleInfo, 0, sizeof(EnsembleInfo)); Tcl_InitHashTable(&infoPtr->ensembleInfo->ensembles, TCL_ONE_WORD_KEYS); @@ -294,19 +247,19 @@ Tcl_IncrRefCount(infoPtr->typeDestructorArgumentPtr); infoPtr->lastIoPtr = NULL; - Tcl_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::classes", "", 0); - Tcl_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::objects", "", 0); - Tcl_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::classOptions", "", 0); - Tcl_SetVar(interp, - ITCL_NAMESPACE"::internal::dicts::classDelegatedOptions", "", 0); - Tcl_SetVar(interp, - ITCL_NAMESPACE"::internal::dicts::classComponents", "", 0); - Tcl_SetVar(interp, - ITCL_NAMESPACE"::internal::dicts::classVariables", "", 0); - Tcl_SetVar(interp, - ITCL_NAMESPACE"::internal::dicts::classFunctions", "", 0); - Tcl_SetVar(interp, - ITCL_NAMESPACE"::internal::dicts::classDelegatedFunctions", "", 0); + Tcl_SetVar2(interp, ITCL_NAMESPACE"::internal::dicts::classes", NULL, "", 0); + Tcl_SetVar2(interp, ITCL_NAMESPACE"::internal::dicts::objects", NULL, "", 0); + Tcl_SetVar2(interp, ITCL_NAMESPACE"::internal::dicts::classOptions", NULL, "", 0); + Tcl_SetVar2(interp, + ITCL_NAMESPACE"::internal::dicts::classDelegatedOptions", NULL, "", 0); + Tcl_SetVar2(interp, + ITCL_NAMESPACE"::internal::dicts::classComponents", NULL, "", 0); + Tcl_SetVar2(interp, + ITCL_NAMESPACE"::internal::dicts::classVariables", NULL, "", 0); + Tcl_SetVar2(interp, + ITCL_NAMESPACE"::internal::dicts::classFunctions", NULL, "", 0); + Tcl_SetVar2(interp, + ITCL_NAMESPACE"::internal::dicts::classDelegatedFunctions", NULL, "", 0); hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes, (char *)Tcl_NewStringObj("class", -1), &isNew); @@ -333,29 +286,22 @@ infoPtr->useOldResolvers = opt; Itcl_InitStack(&infoPtr->clsStack); - Tcl_SetAssocData(interp, ITCL_INTERP_DATA, NULL, (ClientData)infoPtr); - - Itcl_PreserveData((ClientData)infoPtr); + Tcl_SetAssocData(interp, ITCL_INTERP_DATA, NULL, infoPtr); -#ifdef NEW_PROTO_RESOLVER - ItclVarsAndCommandResolveInit(interp); -#endif + Itcl_PreserveData(infoPtr); - objPtr = Tcl_NewStringObj("::oo::class", -1); - root = Tcl_NewObjectInstance(interp, Tcl_GetObjectAsClass( - Tcl_GetObjectFromObj(interp, objPtr)), "::itcl::Root", + root = Tcl_NewObjectInstance(interp, tclCls, "::itcl::Root", NULL, 0, NULL, 0); - Tcl_DecrRefCount(objPtr); Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root), Tcl_NewStringObj("unknown", -1), 0, &itclRootMethodType, - ItclUnknownGuts); + (void *)ItclUnknownGuts); Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root), Tcl_NewStringObj("ItclConstructBase", -1), 0, - &itclRootMethodType, ItclConstructGuts); + &itclRootMethodType, (void *)ItclConstructGuts); Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root), Tcl_NewStringObj("info", -1), 1, - &itclRootMethodType, ItclInfoGuts); + &itclRootMethodType, (void *)ItclInfoGuts); /* first create the Itcl base class as root of itcl classes */ if (Tcl_EvalEx(interp, clazzClassScript, -1, 0) != TCL_OK) { @@ -377,11 +323,9 @@ return TCL_ERROR; } - /* work around for SF bug #254 needed because of problem in TclOO 1.0.2 !! */ - if (Tcl_PkgPresent(interp, "TclOO", "1.0.2", 1) != NULL) { - Itcl_IncrObjectRefCount(clazzObjectPtr); - } + Tcl_ObjectSetMetadata(clazzObjectPtr, &canary, infoPtr); + infoPtr->clazzObjectPtr = clazzObjectPtr; infoPtr->clazzClassPtr = Tcl_GetObjectAsClass(clazzObjectPtr); /* @@ -407,7 +351,7 @@ * Export all commands in the "itcl" namespace so that they * can be imported with something like "namespace import itcl::*" */ - itclNs = Tcl_FindNamespace(interp, "::itcl", (Tcl_Namespace*)NULL, + itclNs = Tcl_FindNamespace(interp, "::itcl", NULL, TCL_LEAVE_ERR_MSG); /* @@ -444,14 +388,14 @@ * Set up the variables containing version info. */ - Tcl_SetVar(interp, "::itcl::version", ITCL_VERSION, TCL_NAMESPACE_ONLY); - Tcl_SetVar(interp, "::itcl::patchLevel", ITCL_PATCH_LEVEL, + Tcl_SetVar2(interp, "::itcl::version", NULL, ITCL_VERSION, TCL_NAMESPACE_ONLY); + Tcl_SetVar2(interp, "::itcl::patchLevel", NULL, ITCL_PATCH_LEVEL, TCL_NAMESPACE_ONLY); #ifdef ITCL_DEBUG_C_INTERFACE RegisterDebugCFunctions(interp); -#endif +#endif /* * Package is now loaded. */ @@ -521,7 +465,7 @@ */ static int ItclSetHullWindowName( - ClientData clientData, /* infoPtr */ + void *clientData, /* infoPtr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -545,7 +489,7 @@ */ static int ItclCheckSetItclHull( - ClientData clientData, /* infoPtr */ + void *clientData, /* infoPtr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -563,7 +507,7 @@ return TCL_ERROR; } - /* + /* * This is an internal command, and is never called with an * objectName value other than the empty list. Check that with * an assertion so alternative handling can be removed. @@ -586,7 +530,7 @@ " variable for object \"", Tcl_GetString(objv[1]), "\"", NULL); return TCL_ERROR; } - ivPtr = Tcl_GetHashValue(hPtr); + ivPtr = (ItclVariable *)Tcl_GetHashValue(hPtr); valueStr = Tcl_GetString(objv[2]); if (strcmp(valueStr, "2") == 0) { ivPtr->initted = 2; @@ -604,244 +548,50 @@ /* * ------------------------------------------------------------------------ - * ItclFinishCmd() + * FreeItclObjectInfo() * - * called when an interp is deleted to free up memory or called explicitly - * to check memory leaks + * called when an interp is deleted to free up memory * * ------------------------------------------------------------------------ */ -static int -ItclFinishCmd( - ClientData clientData, /* unused */ - Tcl_Interp *interp, /* current interpreter */ - int objc, /* number of arguments */ - Tcl_Obj *const objv[]) /* argument objects */ +static void +FreeItclObjectInfo( + void *clientData) { - Tcl_HashEntry *hPtr; - Tcl_HashSearch place; - Tcl_Namespace *nsPtr; - Tcl_Obj **newObjv; - Tcl_Obj *objPtr; - Tcl_Obj *ensObjPtr; - Tcl_Command cmdPtr; - Tcl_Obj *mapDict; - ItclObjectInfo *infoPtr; - ItclCmdsInfo *iciPtr; - int checkMemoryLeaks; - int i; - int result; - - ItclShowArgs(1, "ItclFinishCmd", objc, objv); - result = TCL_OK; - infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); - if (infoPtr == NULL) { - infoPtr = (ItclObjectInfo *)clientData; - } - checkMemoryLeaks = 0; - if (objc > 1) { - if (strcmp(Tcl_GetString(objv[1]), "checkmemoryleaks") == 0) { - /* if we have that option, the namespace of the Tcl ensembles - * is not teared down, so we have to simulate it here to - * have the correct reference counts for infoPtr->infoVars2Ptr - * infoPtr->infoVars3Ptr and infoPtr->infoVars4Ptr - */ - checkMemoryLeaks = 1; - } - } - newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * 2); - newObjv[0] = Tcl_NewStringObj("my", -1);; - for (i = 0; ;i++) { - iciPtr = &itclCmds[i]; - if (iciPtr->name == NULL) { - break; - } - if ((iciPtr->flags & ITCL_IS_ENSEMBLE) == 0) { - result = Itcl_RenameCommand(interp, iciPtr->name, ""); - } else { - objPtr = Tcl_NewStringObj(iciPtr->name, -1); - newObjv[1] = objPtr; - Itcl_EnsembleDeleteCmd(infoPtr, infoPtr->interp, 2, newObjv); - Tcl_DecrRefCount(objPtr); - } - iciPtr++; - } - Tcl_DecrRefCount(newObjv[0]); - ckfree((char *)newObjv); + ItclObjectInfo *infoPtr = (ItclObjectInfo *)clientData; - /* remove the unknown handler, to free the reference to the - * Tcl_Obj with the name of it */ - ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info::delegated", -1); - cmdPtr = Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG); - if (cmdPtr != NULL) { - Tcl_SetEnsembleUnknownHandler(NULL, cmdPtr, NULL); - } - Tcl_DecrRefCount(ensObjPtr); - - while (1) { - hPtr = Tcl_FirstHashEntry(&infoPtr->instances, &place); - if (hPtr == NULL) { - break; - } - Tcl_DeleteHashEntry(hPtr); - } Tcl_DeleteHashTable(&infoPtr->instances); - - while (1) { - hPtr = Tcl_FirstHashEntry(&infoPtr->classTypes, &place); - if (hPtr == NULL) { - break; - } - Tcl_DeleteHashEntry(hPtr); - } Tcl_DeleteHashTable(&infoPtr->classTypes); - Tcl_DeleteHashTable(&infoPtr->procMethods); - Tcl_DeleteHashTable(&infoPtr->objectCmds); Tcl_DeleteHashTable(&infoPtr->classes); Tcl_DeleteHashTable(&infoPtr->nameClasses); Tcl_DeleteHashTable(&infoPtr->namespaceClasses); - nsPtr = Tcl_FindNamespace(interp, "::itcl::parser", NULL, 0); - if (nsPtr != NULL) { - Tcl_DeleteNamespace(nsPtr); - } - - mapDict = NULL; - ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info", -1); - if (Tcl_FindNamespace(interp, Tcl_GetString(ensObjPtr), NULL, 0) != NULL) { - Tcl_SetEnsembleUnknownHandler(NULL, - Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG), - NULL); - } - Tcl_DecrRefCount(ensObjPtr); - - /* remove the vars entry from the info dict */ - /* and replace it by the original one */ - cmdPtr = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); - if (cmdPtr != NULL && Tcl_IsEnsemble(cmdPtr)) { - Tcl_GetEnsembleMappingDict(NULL, cmdPtr, &mapDict); - if (mapDict != NULL) { - - objPtr = Tcl_NewStringObj("vars", -1); - Tcl_IncrRefCount(objPtr); - Tcl_DictObjRemove(interp, mapDict, objPtr); - Tcl_DictObjPut(interp, mapDict, objPtr, infoPtr->infoVars4Ptr); - Tcl_DecrRefCount(objPtr); - Tcl_SetEnsembleMappingDict(interp, cmdPtr, mapDict); - } - } - /* FIXME have to figure out why the refCount of - * ::itcl::builtin::Info - * and ::itcl::builtin::Info::vars and vars is 2 here !! */ - /* seems to be as the tclOO commands are not yet deleted ?? */ - Tcl_DecrRefCount(infoPtr->infoVars3Ptr); - Tcl_DecrRefCount(infoPtr->infoVars4Ptr); - if (checkMemoryLeaks) { - Tcl_DecrRefCount(infoPtr->infoVars3Ptr); - Tcl_DecrRefCount(infoPtr->infoVars4Ptr); - /* see comment above */ - } - - Tcl_DecrRefCount(infoPtr->typeDestructorArgumentPtr); - - Tcl_EvalEx(infoPtr->interp, - "::oo::define ::itcl::clazz deletemethod unknown", -1, 0); - - /* first have to look for the remaining memory leaks, then remove the next ifdef */ - Itcl_RenameCommand(infoPtr->interp, "::itcl::clazz", ""); - - /* tear down ::itcl namespace (this includes ::itcl::parser namespace) */ - nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::parser", NULL, 0); - if (nsPtr != NULL) { - Tcl_DeleteNamespace(nsPtr); - } - nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::import", NULL, 0); - if (nsPtr != NULL) { - Tcl_DeleteNamespace(nsPtr); - } - nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::internal", NULL, 0); - if (nsPtr != NULL) { - Tcl_DeleteNamespace(nsPtr); - } - nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::builtin", NULL, 0); - if (nsPtr != NULL) { - Tcl_DeleteNamespace(nsPtr); - } - nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl", NULL, 0); - if (nsPtr != NULL) { - Tcl_DeleteNamespace(nsPtr); + assert (infoPtr->infoVarsPtr == NULL); + assert (infoPtr->infoVars4Ptr == NULL); + + if (infoPtr->typeDestructorArgumentPtr) { + Tcl_DecrRefCount(infoPtr->typeDestructorArgumentPtr); + infoPtr->typeDestructorArgumentPtr = NULL; } /* cleanup ensemble info */ - ItclFinishEnsemble(infoPtr); + if (infoPtr->ensembleInfo) { + Tcl_DeleteHashTable(&infoPtr->ensembleInfo->ensembles); + Tcl_DeleteHashTable(&infoPtr->ensembleInfo->subEnsembles); + ItclFinishEnsemble(infoPtr); + ckfree((char *)infoPtr->ensembleInfo); + infoPtr->ensembleInfo = NULL; + } - ckfree((char *)infoPtr->class_meta_type); + if (infoPtr->class_meta_type) { + ckfree((char *)infoPtr->class_meta_type); + infoPtr->class_meta_type = NULL; + } - Itcl_DeleteStack(&infoPtr->clsStack); /* clean up list pool */ Itcl_FinishList(); - Itcl_ReleaseData((ClientData)infoPtr); - return result; -} - -#ifdef OBJ_REF_COUNT_DEBUG -void Tcl_DbDumpRefCountInfo(const char *fileName, int noDeleted); - - -/* - * ------------------------------------------------------------------------ - * ItclDumpRefCountInfo() - * - * debugging routine to check for memory leaks in use of Tcl_Obj's - * - * ------------------------------------------------------------------------ - */ -static int -ItclDumpRefCountInfo( - ClientData clientData, /* unused */ - Tcl_Interp *interp, /* current interpreter */ - int objc, /* number of arguments */ - Tcl_Obj *const objv[]) /* argument objects */ -{ - int noDeleted; - - noDeleted = 0; - if (objc > 1) { - if (strcmp(Tcl_GetString(objv[1]), "-nodeleted") == 0) { - noDeleted = 1; - } - } - ItclShowArgs(0, "ItclDumpRefCountInfo", objc, objv); - Tcl_DbDumpRefCountInfo(NULL, noDeleted); - return TCL_OK; -} -#endif - -#ifdef ITCL_PRESERVE_DEBUG -void Itcl_DbDumpPreserveInfo(const char *fileName); - - -/* - * ------------------------------------------------------------------------ - * ItclDumpPreserveInfo() - * - * debugging routine to check for memory leaks in use of Itcl_PreserveData - * and Itcl_ReleaseData - * - * ------------------------------------------------------------------------ - */ -static int -ItclDumpPreserveInfo( - ClientData clientData, /* unused */ - Tcl_Interp *interp, /* current interpreter */ - int objc, /* number of arguments */ - Tcl_Obj *const objv[]) /* argument objects */ -{ - ItclShowArgs(0, "ItclDumpPreserveInfo", objc, objv); - Itcl_DbDumpPreserveInfo(NULL); - return TCL_OK; + Itcl_ReleaseData(infoPtr); } -#endif diff -Nru itcl4-4.1.2/generic/itclBuiltin.c itcl4-4.2.0/generic/itclBuiltin.c --- itcl4-4.1.2/generic/itclBuiltin.c 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/generic/itclBuiltin.c 2019-11-03 02:24:15.000000000 +0000 @@ -262,6 +262,51 @@ /* * ------------------------------------------------------------------------ + * ItclRestoreInfoVars() + * + * Delete callback to restore original "info" ensemble (revert inject of Itcl) + * + * ------------------------------------------------------------------------ + */ + +void +ItclRestoreInfoVars( + ClientData clientData) +{ + ItclObjectInfo *infoPtr = (ItclObjectInfo *)clientData; + Tcl_Interp *interp = infoPtr->interp; + Tcl_Command cmd; + Tcl_Obj *mapDict; + + cmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); + if (cmd == NULL || !Tcl_IsEnsemble(cmd)) { + goto done; + } + Tcl_GetEnsembleMappingDict(NULL, cmd, &mapDict); + if (mapDict == NULL) { + goto done; + } + if (infoPtr->infoVarsPtr == NULL || infoPtr->infoVars4Ptr == NULL) { + /* Safety */ + goto done; + } + Tcl_DictObjPut(NULL, mapDict, infoPtr->infoVars4Ptr, infoPtr->infoVarsPtr); + Tcl_SetEnsembleMappingDict(interp, cmd, mapDict); + +done: + if (infoPtr->infoVarsPtr) { + Tcl_DecrRefCount(infoPtr->infoVarsPtr); + infoPtr->infoVarsPtr = NULL; + } + if (infoPtr->infoVars4Ptr) { + Tcl_DecrRefCount(infoPtr->infoVars4Ptr); + infoPtr->infoVars4Ptr = NULL; + } +} + + +/* + * ------------------------------------------------------------------------ * Itcl_BiInit() * * Creates a namespace full of built-in methods/procs for [incr Tcl] @@ -272,6 +317,7 @@ * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ + int Itcl_BiInit( Tcl_Interp *interp, /* current interpreter */ @@ -295,16 +341,15 @@ Tcl_DStringAppend(&buffer, "::itcl::builtin::", -1); Tcl_DStringAppend(&buffer, BiMethodList[i].name, -1); Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), - BiMethodList[i].proc, (ClientData)infoPtr, - (Tcl_CmdDeleteProc*)NULL); + BiMethodList[i].proc, infoPtr, NULL); } Tcl_DStringFree(&buffer); Tcl_CreateObjCommand(interp, "::itcl::builtin::chain", Itcl_BiChainCmd, - NULL, (Tcl_CmdDeleteProc*)NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "::itcl::builtin::classunknown", - ItclBiClassUnknownCmd, infoPtr, (Tcl_CmdDeleteProc*)NULL); + ItclBiClassUnknownCmd, infoPtr, NULL); ItclInfoInit(interp, infoPtr); /* @@ -312,7 +357,7 @@ * import them later on. */ itclBiNs = Tcl_FindNamespace(interp, "::itcl::builtin", - (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); + NULL, TCL_LEAVE_ERR_MSG); if ((itclBiNs == NULL) || Tcl_Export(interp, itclBiNs, "[a-z]*", /* resetListFirst */ 1) != TCL_OK) { @@ -326,22 +371,23 @@ if (infoCmd != NULL && Tcl_IsEnsemble(infoCmd)) { Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); if (mapDict != NULL) { - infoPtr->infoVars4Ptr = - Tcl_NewStringObj("vars", -1); + infoPtr->infoVars4Ptr = Tcl_NewStringObj("vars", -1); Tcl_IncrRefCount(infoPtr->infoVars4Ptr); - result = Tcl_DictObjGet(interp, mapDict, infoPtr->infoVars4Ptr, + result = Tcl_DictObjGet(NULL, mapDict, infoPtr->infoVars4Ptr, &infoPtr->infoVarsPtr); - if(result != TCL_OK) { - /* FIXME need code here!! */ + if (result == TCL_OK && infoPtr->infoVarsPtr) { + Tcl_IncrRefCount(infoPtr->infoVarsPtr); + Tcl_DictObjPut(NULL, mapDict, infoPtr->infoVars4Ptr, + Tcl_NewStringObj("::itcl::builtin::Info::vars", -1)); + Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); + /* + * Note that ItclRestoreInfoVars is called in callback + * if built-in Itcl command info::vars or the ensemble get + * deleted (see ItclInfoInit registering that). */ + } else { + Tcl_DecrRefCount(infoPtr->infoVars4Ptr); + infoPtr->infoVars4Ptr = NULL; } - - infoPtr->infoVars3Ptr = - Tcl_NewStringObj("::itcl::builtin::Info::vars", -1); - /* FIXME see comment in itclBase.c ItclFinishCmd */ - Tcl_IncrRefCount(infoPtr->infoVars3Ptr); - Tcl_DictObjPut(NULL, mapDict, infoPtr->infoVars4Ptr, - infoPtr->infoVars3Ptr); - Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); } } @@ -444,7 +490,7 @@ /* ARGSUSED */ int Itcl_BiIsaCmd( - ClientData clientData, /* class definition */ + void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -467,14 +513,14 @@ if (contextIoPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "improper usage: should be \"object isa className\"", - (char*)NULL); + NULL); return TCL_ERROR; } if (objc != 2) { token = Tcl_GetString(objv[0]); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"object ", token, " className\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -490,9 +536,9 @@ } if (Itcl_ObjectIsa(contextIoPtr, iclsPtr)) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 1); } else { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 0); } return TCL_OK; } @@ -523,7 +569,7 @@ /* ARGSUSED */ int Itcl_BiConfigureCmd( - ClientData clientData, /* class definition */ + void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -574,7 +620,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "improper usage: should be ", "\"object configure ?-option? ?value -option value...?\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -607,7 +653,7 @@ * HANDLE: configure */ if (unparsedObjc == 1) { - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { @@ -617,7 +663,7 @@ if (ivPtr->protection == ITCL_PUBLIC) { objPtr = ItclReportPublicOpt(interp, ivPtr, contextIoPtr); - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } hPtr = Tcl_NextHashEntry(&place); @@ -633,17 +679,17 @@ * HANDLE: configure -option */ if (unparsedObjc == 2) { - token = Tcl_GetStringFromObj(unparsedObjv[1], (int*)NULL); + token = Tcl_GetString(unparsedObjv[1]); if (*token != '-') { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "improper usage: should be ", "\"object configure ?-option? ?value -option value...?\"", - (char*)NULL); + NULL); return TCL_ERROR; } vlookup = NULL; - hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, token+1); + hPtr = ItclResolveVarEntry(contextIclsPtr, token+1); if (hPtr) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); @@ -654,7 +700,7 @@ if (!vlookup) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown option \"", token, "\"", - (char*)NULL); + NULL); return TCL_ERROR; } resultPtr = ItclReportPublicOpt(interp, @@ -684,9 +730,9 @@ vlookup = NULL; token = Tcl_GetString(unparsedObjv[i]); if (*token == '-') { - hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, token+1); + hPtr = ItclResolveVarEntry(contextIclsPtr, token+1); if (hPtr == NULL) { - hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, token); + hPtr = ItclResolveVarEntry(contextIclsPtr, token); } if (hPtr) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); @@ -695,13 +741,13 @@ if (!vlookup || (vlookup->ivPtr->protection != ITCL_PUBLIC)) { Tcl_AppendResult(interp, "unknown option \"", token, "\"", - (char*)NULL); + NULL); result = TCL_ERROR; goto configureDone; } if (i == unparsedObjc-1) { Tcl_AppendResult(interp, "value for \"", token, "\" missing", - (char*)NULL); + NULL); result = TCL_ERROR; goto configureDone; } @@ -718,12 +764,12 @@ Tcl_DStringAppend(&buffer2, Tcl_GetString(ivPtr->namePtr), -1); varName = Tcl_DStringValue(&buffer2); - lastval = Tcl_GetVar2(interp, varName, (char*)NULL, 0); + lastval = Tcl_GetVar2(interp, varName, NULL, 0); Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, (lastval) ? lastval : "", -1); token = Tcl_GetString(unparsedObjv[i+1]); - if (Tcl_SetVar2(interp, varName, (char*)NULL, token, + if (Tcl_SetVar2(interp, varName, NULL, token, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (error in configuration of public variable \"%s\")", @@ -755,7 +801,7 @@ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (error in configuration of public variable \"%s\")", Tcl_GetString(ivPtr->fullNamePtr))); - Tcl_SetVar2(interp, varName,(char*)NULL, + Tcl_SetVar2(interp, varName,NULL, Tcl_DStringValue(&buffer), 0); goto configureDone; @@ -765,6 +811,9 @@ configureDone: if (infoPtr->unparsedObjc > 0) { + while (infoPtr->unparsedObjc-- > 1) { + Tcl_DecrRefCount(infoPtr->unparsedObjv[infoPtr->unparsedObjc]); + } ckfree ((char *)infoPtr->unparsedObjv); infoPtr->unparsedObjv = NULL; infoPtr->unparsedObjc = 0; @@ -794,7 +843,7 @@ /* ARGSUSED */ int Itcl_BiCgetCmd( - ClientData clientData, /* class definition */ + void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -820,7 +869,7 @@ if ((contextIoPtr == NULL) || objc != 2) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "improper usage: should be \"object cget -option\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -840,7 +889,7 @@ name = Tcl_GetString(objv[1]); vlookup = NULL; - hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, name+1); + hPtr = ItclResolveVarEntry(contextIclsPtr, name+1); if (hPtr) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); } @@ -848,7 +897,7 @@ if ((vlookup == NULL) || (vlookup->ivPtr->protection != ITCL_PUBLIC)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown option \"", name, "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -892,7 +941,7 @@ Tcl_Obj *listPtr; Tcl_Obj *objPtr; - listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + listPtr = Tcl_NewListObj(0, NULL); /* * Determine how the option name should be reported. @@ -904,14 +953,14 @@ Tcl_DStringAppend(&optName, "-", -1); iclsPtr = (ItclClass*)contextIoPtr->iclsPtr; - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, + hPtr = ItclResolveVarEntry(iclsPtr, Tcl_GetString(ivPtr->fullNamePtr)); assert(hPtr != NULL); vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); Tcl_DStringAppend(&optName, vlookup->leastQualName, -1); objPtr = Tcl_NewStringObj(Tcl_DStringValue(&optName), -1); - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr); + Tcl_ListObjAppendElement(NULL, listPtr, objPtr); Tcl_DStringFree(&optName); @@ -920,7 +969,7 @@ } else { objPtr = Tcl_NewStringObj("", -1); } - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr); + Tcl_ListObjAppendElement(NULL, listPtr, objPtr); val = Itcl_GetInstanceVar(interp, Tcl_GetString(ivPtr->namePtr), contextIoPtr, ivPtr->iclsPtr); @@ -930,7 +979,7 @@ } else { objPtr = Tcl_NewStringObj("", -1); } - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr); + Tcl_ListObjAppendElement(NULL, listPtr, objPtr); return listPtr; } @@ -959,31 +1008,31 @@ ItclDelegatedOption *idoPtr; const char *val; - listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + listPtr = Tcl_NewListObj(0, NULL); idoPtr = ioptPtr->iclsPtr->infoPtr->currIdoPtr; if (idoPtr != NULL) { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, idoPtr->namePtr); + Tcl_ListObjAppendElement(NULL, listPtr, idoPtr->namePtr); if (idoPtr->resourceNamePtr == NULL) { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj("", -1)); /* FIXME possible memory leak */ } else { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + Tcl_ListObjAppendElement(NULL, listPtr, idoPtr->resourceNamePtr); } if (idoPtr->classNamePtr == NULL) { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj("", -1)); /* FIXME possible memory leak */ } else { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + Tcl_ListObjAppendElement(NULL, listPtr, idoPtr->classNamePtr); } } else { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, ioptPtr->namePtr); - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + Tcl_ListObjAppendElement(NULL, listPtr, ioptPtr->namePtr); + Tcl_ListObjAppendElement(NULL, listPtr, ioptPtr->resourceNamePtr); - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + Tcl_ListObjAppendElement(NULL, listPtr, ioptPtr->classNamePtr); } if (ioptPtr->defaultValuePtr) { @@ -991,7 +1040,7 @@ } else { objPtr = Tcl_NewStringObj("", -1); } - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr); + Tcl_ListObjAppendElement(NULL, listPtr, objPtr); val = ItclGetInstanceVar(interp, "itcl_options", Tcl_GetString(ioptPtr->namePtr), contextIoPtr, ioptPtr->iclsPtr); @@ -1000,7 +1049,7 @@ } else { objPtr = Tcl_NewStringObj("", -1); } - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr); + Tcl_ListObjAppendElement(NULL, listPtr, objPtr); return listPtr; } @@ -1027,7 +1076,7 @@ /* ARGSUSED */ static int NRBiChainCmd( - ClientData dummy, /* not used */ + void *dummy, /* not used */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -1063,7 +1112,7 @@ Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot chain functions outside of a class context", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -1137,7 +1186,7 @@ cmdlinePtr = Itcl_CreateArgs(interp, Tcl_GetString(imPtr->fullNamePtr), objc-1, objv+1); - (void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr, + (void) Tcl_ListObjGetElements(NULL, cmdlinePtr, &my_objc, &newobjv); if (imPtr->flags & ITCL_CONSTRUCTOR) { @@ -1159,7 +1208,7 @@ /* ARGSUSED */ int Itcl_BiChainCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1169,15 +1218,15 @@ static int CallCreateObject( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { Tcl_CallFrame frame; Tcl_Namespace *nsPtr; - ItclClass *iclsPtr = data[0]; + ItclClass *iclsPtr = (ItclClass *)data[0]; int objc = PTR2INT(data[1]); - Tcl_Obj *const *objv = data[2]; + Tcl_Obj *const *objv = (Tcl_Obj *const *)data[2]; if (result != TCL_OK) { return result; @@ -1238,7 +1287,7 @@ callbackPtr = Itcl_GetCurrentCallbackPtr(interp); ItclShowArgs(1, "CREATE", objc+3-offset, newObjv); Tcl_NRAddCallback(interp, CallCreateObject, iclsPtr, - INT2PTR(objc+3-offset), (ClientData)newObjv, NULL); + INT2PTR(objc+3-offset), newObjv, NULL); result = Itcl_NRRunCallbacks(interp, callbackPtr); if (result != TCL_OK) { if (iclsPtr->infoPtr->currIoPtr != NULL) { @@ -1266,7 +1315,7 @@ /* ARGSUSED */ static int ItclBiClassUnknownCmd( - ClientData clientData, /* ItclObjectInfo Ptr */ + void *clientData, /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -1313,7 +1362,7 @@ "cannot find class\n", NULL); return TCL_ERROR; } - iclsPtr = Tcl_GetHashValue(hPtr); + iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); funcName = Tcl_GetString(objv[1]); if (strcmp(funcName, "create") == 0) { /* check if we have a user method create. If not, it is the builtin @@ -1381,7 +1430,7 @@ (char *)objPtr); Tcl_DecrRefCount(objPtr); if (hPtr != NULL) { - idmPtr = Tcl_GetHashValue(hPtr); + idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); isStar = 1; } } @@ -1409,7 +1458,7 @@ } } if (hPtr != NULL) { - idmPtr = Tcl_GetHashValue(hPtr); + idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); val = NULL; if (idmPtr->icPtr != NULL) { if (idmPtr->icPtr->ivPtr->flags & ITCL_COMMON) { @@ -1510,7 +1559,7 @@ Tcl_DecrRefCount(listPtr); } if (result == TCL_ERROR) { - resStr = Tcl_GetStringResult(interp); + resStr = Tcl_GetString(Tcl_GetObjResult(interp)); /* FIXME ugly hack at the moment !! */ if (strncmp(resStr, "wrong # args: should be ", 24) == 0) { resPtr = Tcl_NewStringObj("", -1); @@ -1575,7 +1624,7 @@ if (objc < 2) { Tcl_AppendResult(interp, "wrong # args: should be one of...", - (char*)NULL); + NULL); ItclReportObjectUsage(interp, ioPtr, NULL, NULL); return TCL_ERROR; } @@ -1644,12 +1693,12 @@ (char *)objPtr); Tcl_DecrRefCount(objPtr); if (hPtr != NULL) { - idmPtr = Tcl_GetHashValue(hPtr); + idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); isStar = 1; } } else { - found = 1; - idmPtr = Tcl_GetHashValue(hPtr); + found = 1; + idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); } if (isStar) { /* check if the function is in the exceptions */ @@ -1730,7 +1779,7 @@ } if (idmPtr == NULL) { Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]), - "\": should be one of...", (char*)NULL); + "\": should be one of...", NULL); ItclReportObjectUsage(interp, ioPtr, NULL, NULL); return TCL_ERROR; } @@ -1809,7 +1858,7 @@ if (result == TCL_OK) { return TCL_OK; } - resStr = Tcl_GetStringResult(interp); + resStr = Tcl_GetString(Tcl_GetObjResult(interp)); /* FIXME ugly hack at the moment !! */ if (strncmp(resStr, "wrong # args: should be ", 24) == 0) { resPtr = Tcl_NewStringObj("", -1); @@ -1874,7 +1923,7 @@ /* ARGSUSED */ static int ItclExtendedConfigure( - ClientData clientData, /* class definition */ + void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -1935,7 +1984,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "improper usage: should be ", "\"object configure ?-option? ?value -option value...?\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -2311,9 +2360,8 @@ ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr2); resultPtr = ItclReportOption(interp, ioptPtr, contextIoPtr); infoPtr->currIdoPtr = saveIdoPtr; - Tcl_SetResult(interp, Tcl_GetString(resultPtr), TCL_VOLATILE); - Tcl_DecrRefCount(resultPtr); - return TCL_OK; + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; } result = TCL_OK; /* set one or more options */ @@ -2413,6 +2461,7 @@ infoPtr->unparsedObjv[infoPtr->unparsedObjc-2] = objv[i]; Tcl_IncrRefCount(infoPtr->unparsedObjv[infoPtr->unparsedObjc-2]); infoPtr->unparsedObjv[infoPtr->unparsedObjc-1] = objv[i+1]; + Tcl_IncrRefCount(infoPtr->unparsedObjv[infoPtr->unparsedObjc-1]); /* check if normal public variable/common ? */ /* FIXME !!! temporary */ continue; @@ -2541,7 +2590,7 @@ /* ARGSUSED */ static int ItclExtendedCget( - ClientData clientData, /* class definition */ + void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -2578,7 +2627,7 @@ if ((contextIoPtr == NULL) || objc != 2) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "improper usage: should be \"object cget -option\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -2779,7 +2828,7 @@ /* ARGSUSED */ static int ItclExtendedSetGet( - ClientData clientData, /* class definition */ + void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -2811,7 +2860,7 @@ usageStr = "improper usage: should be \"object setget varName ?value?\""; if (contextIoPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - usageStr, (char*)NULL); + usageStr, NULL); return TCL_ERROR; } @@ -2829,7 +2878,7 @@ hPtr = NULL; if (objc < 2) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - usageStr, (char*)NULL); + usageStr, NULL); return TCL_ERROR; } /* look if it is an methodvariable at all */ @@ -2847,7 +2896,7 @@ if (val == NULL) { result = TCL_ERROR; } else { - Tcl_SetResult(interp, (char *)val, TCL_VOLATILE); + Tcl_SetObjResult(interp, Tcl_NewStringObj(val, -1)); } return result; } @@ -2897,7 +2946,7 @@ /* ARGSUSED */ int Itcl_BiInstallComponentCmd( - ClientData clientData, /* class definition */ + void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -2928,7 +2977,7 @@ if (contextIoPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "improper usage: should be \"object installcomponent \"", - (char*)NULL); + NULL); return TCL_ERROR; } if (objc < 5) { @@ -2938,7 +2987,7 @@ "wrong # args: should be \"", token, " using", " ", " ?-option value -option value ...?\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -2991,10 +3040,11 @@ memcpy(newObjv, objv + 3, sizeof(Tcl_Obj *) * ((objc - 3))); ItclShowArgs(1, "BiInstallComponent", objc - 3, newObjv); result = Tcl_EvalObjv(interp, objc - 3, newObjv, 0); + ckfree((char *)newObjv); if (result != TCL_OK) { return result; } - componentValue = Tcl_GetStringResult(interp); + componentValue = Tcl_GetString(Tcl_GetObjResult(interp)); objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, -1); Tcl_AppendToObj(objPtr, (Tcl_GetObjectNamespace(contextIclsPtr->oPtr))->fullName, -1); @@ -3002,6 +3052,7 @@ Tcl_AppendToObj(objPtr, componentName, -1); Tcl_SetVar2(interp, Tcl_GetString(objPtr), NULL, componentValue, 0); + Tcl_DecrRefCount(objPtr); } else { newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc + 1)); @@ -3030,7 +3081,7 @@ /* ARGSUSED */ static int Itcl_BiDestroyCmd( - ClientData clientData, /* class definition */ + void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -3077,7 +3128,7 @@ } if (objc != 1) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"", Tcl_GetString(objv[0]), (char*)NULL); + "wrong # args: should be \"", Tcl_GetString(objv[0]), NULL); return TCL_ERROR; } @@ -3107,7 +3158,7 @@ /* ARGSUSED */ int Itcl_BiCallInstanceCmd( - ClientData clientData, /* class definition */ + void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -3135,7 +3186,7 @@ token = Tcl_GetString(objv[0]); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"", token, " ", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -3147,7 +3198,7 @@ Tcl_GetString(objv[1]), "\"", NULL); return TCL_ERROR; } - ioPtr = Tcl_GetHashValue(hPtr); + ioPtr = (ItclObject *)Tcl_GetHashValue(hPtr); objPtr =Tcl_NewObj(); Tcl_GetCommandFullName(interp, ioPtr->accessCmd, objPtr); newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * (objc - 1)); @@ -3174,7 +3225,7 @@ /* ARGSUSED */ int Itcl_BiGetInstanceVarCmd( - ClientData clientData, /* class definition */ + void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -3202,7 +3253,7 @@ token = Tcl_GetString(objv[0]); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"", token, " ", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -3214,8 +3265,8 @@ Tcl_GetString(objv[1]), "\"", NULL); return TCL_ERROR; } - ioPtr = Tcl_GetHashValue(hPtr); - objPtr =Tcl_NewObj(); + ioPtr = (ItclObject *)Tcl_GetHashValue(hPtr); + objPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, ioPtr->accessCmd, objPtr); newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * (objc - 1)); newObjv[0] = objPtr; @@ -3240,7 +3291,7 @@ /* ARGSUSED */ int Itcl_BiMyTypeMethodCmd( - ClientData clientData, /* class definition */ + void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -3290,7 +3341,7 @@ /* ARGSUSED */ int Itcl_BiMyMethodCmd( - ClientData clientData, /* class definition */ + void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -3339,7 +3390,7 @@ /* ARGSUSED */ int Itcl_BiMyProcCmd( - ClientData clientData, /* class definition */ + void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -3390,7 +3441,7 @@ /* ARGSUSED */ int Itcl_BiMyTypeVarCmd( - ClientData clientData, /* class definition */ + void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -3442,7 +3493,7 @@ /* ARGSUSED */ int Itcl_BiMyVarCmd( - ClientData clientData, /* class definition */ + void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -3486,7 +3537,7 @@ /* ARGSUSED */ int Itcl_BiItclHullCmd( - ClientData clientData, /* class definition */ + void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -3528,7 +3579,7 @@ */ static int Itcl_BiCreateHullCmd( - ClientData clientData, /* info for all known objects */ + void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -3563,7 +3614,7 @@ */ static int Itcl_BiSetupComponentCmd( - ClientData clientData, /* info for all known objects */ + void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -3593,13 +3644,13 @@ * * itcl_initoptions * ? ...? - * FIXME !!!! seems no longer been used !!! + * FIXME !!!! seems no longer been used !!! * * ------------------------------------------------------------------------ */ static int Itcl_BiInitOptionsCmd( - ClientData clientData, /* info for all known objects */ + void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -3651,7 +3702,7 @@ */ static int Itcl_BiKeepComponentOptionCmd( - ClientData clientData, /* info for all known objects */ + void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -3686,7 +3737,7 @@ */ static int Itcl_BiIgnoreComponentOptionCmd( - ClientData clientData, /* info for all known objects */ + void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ @@ -3729,7 +3780,7 @@ Tcl_GetString(objv[1]), "\"", NULL); return TCL_ERROR; } - icPtr = Tcl_GetHashValue(hPtr); + icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); icPtr->haveKeptOptions = 1; for (idx = 2; idx < objc; idx++) { hPtr = Tcl_CreateHashEntry(&icPtr->keptOptions, (char *)objv[idx], @@ -3769,7 +3820,7 @@ if (result == TCL_OK) { ItclSetInstanceVar(interp, "itcl_options", Tcl_GetString(objv[idx]), - Tcl_GetStringResult(interp), ioPtr, iclsPtr); + Tcl_GetString(Tcl_GetObjResult(interp)), ioPtr, iclsPtr); } } } diff -Nru itcl4-4.1.2/generic/itclClass.c itcl4-4.2.0/generic/itclClass.c --- itcl4-4.1.2/generic/itclClass.c 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/generic/itclClass.c 2019-11-05 14:34:35.000000000 +0000 @@ -57,7 +57,7 @@ { ItclClass *iclsPtr = (ItclClass *)clientData; - if (--iclsPtr->refCount == 0) { + if (iclsPtr->refCount-- <= 1) { ItclFreeClass((char *) clientData); } } @@ -70,7 +70,7 @@ */ void Itcl_DeleteMemberFunc ( - char *cdata) + void *cdata) { /* needed for stubs compatibility */ ItclMemberFunc *imPtr; @@ -93,69 +93,14 @@ ItclDestroyClass2( ClientData clientData) /* The class being deleted. */ { - ItclClass *iclsPtr; + ItclClass *iclsPtr = (ItclClass *)clientData; - iclsPtr = clientData; ItclDestroyClassNamesp(iclsPtr); ItclReleaseClass(iclsPtr); } /* * ------------------------------------------------------------------------ - * ClassCmdDeleteTrace() - * - * ------------------------------------------------------------------------ - */ - -static void -ClassCmdDeleteTrace( - ClientData clientData, /* The class being deleted. */ - Tcl_Interp *interp, /* The interpreter containing the object. */ - const char *oldName, /* What the object was (last) called. */ - const char *newName, /* Always NULL. */ - int flags) /* Why was the object deleted? */ -{ - Tcl_HashEntry *hPtr; - Tcl_DString buffer; - Tcl_Namespace *nsPtr; - ItclObjectInfo *infoPtr; - ItclClass *iclsPtr = clientData; - - /* - * How is it decided what cleanup is done here tracing the access command deletion, - * versus what cleanup is done by the Tcl_CmdDeleteProc tied to the access command? - */ - - infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); - hPtr = Tcl_FindHashEntry(&infoPtr->classes, (char *)iclsPtr); - if (hPtr == NULL) { - return; - } - if (iclsPtr->flags & ITCL_CLASS_IS_RENAMED) { /* DUMB! name for this flag */ - return; /* Flag very likely serves no purpose as well. */ - } - iclsPtr->flags |= ITCL_CLASS_IS_RENAMED; /* DUMB! name for this flag */ - ItclPreserveClass(iclsPtr); - /* delete the namespace for the common variables */ - Tcl_DStringInit(&buffer); - Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); - Tcl_DStringAppend(&buffer, - (Tcl_GetObjectNamespace(iclsPtr->oPtr))->fullName, -1); - nsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), NULL, 0); - Tcl_DStringFree(&buffer); - if (nsPtr != NULL) { - Tcl_DeleteNamespace(nsPtr); - } - if (!(iclsPtr->flags & ITCL_CLASS_NS_IS_DESTROYED)) { - ItclDestroyClassNamesp(iclsPtr); - } - ItclReleaseClass(iclsPtr); - return; -} - - -/* - * ------------------------------------------------------------------------ * ItclDeleteClassMetadata() * * Delete the metadata data if any @@ -170,12 +115,12 @@ * to an Itcl class (or its namespace...) is being torn down. */ - ItclClass *iclsPtr = clientData; + ItclClass *iclsPtr = (ItclClass *)clientData; Tcl_Object oPtr = iclsPtr->oPtr; Tcl_Namespace *ooNsPtr = Tcl_GetObjectNamespace(oPtr); if (ooNsPtr != iclsPtr->nsPtr) { - /* + /* * Itcl's idea of the class namespace is different from that of TclOO. * Make sure both get torn down and pulled from tables. */ @@ -197,13 +142,16 @@ Tcl_Interp *interp, int result) { - ItclObjectInfo *infoPtr = data[0]; - const char* path = data[1]; - Tcl_Object *oPtr = data[2]; - Tcl_Obj *nameObjPtr = data[3]; - - *oPtr = Tcl_NewObjectInstance(interp, infoPtr->clazzClassPtr, - path, path, 0, NULL, 0); + ItclObjectInfo *infoPtr = (ItclObjectInfo *)data[0]; + const char *path = (const char *)data[1]; + Tcl_Object *oPtr = (Tcl_Object *)data[2]; + Tcl_Obj *nameObjPtr = (Tcl_Obj *)data[3]; + + *oPtr = NULL; + if (infoPtr->clazzClassPtr) { + *oPtr = Tcl_NewObjectInstance(interp, infoPtr->clazzClassPtr, + path, path, 0, NULL, 0); + } if (*oPtr == NULL) { Tcl_AppendResult(interp, "ITCL: cannot create Tcl_NewObjectInstance for class \"", @@ -246,7 +194,11 @@ int result; int newEntry; ItclResolveInfo *resolveInfoPtr; - Tcl_Obj *cmdNamePtr; + + if (infoPtr->clazzObjectPtr == NULL) { + Tcl_AppendResult(interp, "oo-subsystem is deleted", NULL); + return TCL_ERROR; + } /* * check for an empty class name to avoid a crash @@ -264,12 +216,12 @@ * proper class data. */ classNs = Tcl_FindNamespace(interp, (const char *)path, - (Tcl_Namespace*)NULL, /* flags */ 0); + NULL, /* flags */ 0); if (classNs != NULL && Itcl_IsClassNamespace(classNs)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "class \"", path, "\" already exists", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -281,18 +233,18 @@ * makes a bogus call like "class info". */ cmd = Tcl_FindCommand(interp, (const char *)path, - (Tcl_Namespace*)NULL, /* flags */ TCL_NAMESPACE_ONLY); + NULL, /* flags */ TCL_NAMESPACE_ONLY); if (cmd != NULL && !Itcl_IsStub(cmd)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "command \"", path, "\" already exists", - (char*)NULL); + NULL); if (strstr(path,"::") == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " in namespace \"", Tcl_GetCurrentNamespace(interp)->fullName, "\"", - (char*)NULL); + NULL); } return TCL_ERROR; } @@ -308,7 +260,7 @@ if (strstr(tail,".")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad class name \"", tail, "\"", - (char*)NULL); + NULL); Tcl_DStringFree(&buffer); return TCL_ERROR; } @@ -321,7 +273,7 @@ memset(iclsPtr, 0, sizeof(ItclClass)); iclsPtr->interp = interp; iclsPtr->infoPtr = infoPtr; - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); Tcl_InitObjHashTable(&iclsPtr->variables); Tcl_InitObjHashTable(&iclsPtr->functions); @@ -334,14 +286,14 @@ iclsPtr->numInstanceVars = 0; Tcl_InitHashTable(&iclsPtr->classCommons, TCL_ONE_WORD_KEYS); - Tcl_InitHashTable(&iclsPtr->resolveVars, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&iclsPtr->resolveVars, TCL_STRING_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)); @@ -398,7 +350,7 @@ * ?? */ Tcl_NRAddCallback(interp, CallNewObjectInstance, infoPtr, - (ClientData)path, &oPtr, nameObjPtr); + (void *)path, &oPtr, nameObjPtr); result = Itcl_NRRunCallbacks(interp, callbackPtr); if (result == TCL_ERROR) { result = TCL_ERROR; @@ -415,7 +367,7 @@ Tcl_SetCommandInfoFromToken(cmd, &cmdInfo); ooNs = Tcl_GetObjectNamespace(oPtr); classNs = Tcl_FindNamespace(interp, Tcl_GetString(nameObjPtr), - (Tcl_Namespace*)NULL, /* flags */ 0); + NULL, /* flags */ 0); if (_TclOONamespaceDeleteProc == NULL) { _TclOONamespaceDeleteProc = ooNs->deleteProc; } @@ -428,16 +380,6 @@ } if (iclsPtr->infoPtr->useOldResolvers) { -#ifdef NEW_PROTO_RESOLVER - Itcl_SetNamespaceResolvers(ooNs, - (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver2, - (Tcl_ResolveVarProc*)Itcl_ClassVarResolver2, - (Tcl_ResolveCompiledVarProc*)Itcl_ClassCompiledVarResolver2); - Itcl_SetNamespaceResolvers(classNs, - (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver2, - (Tcl_ResolveVarProc*)Itcl_ClassVarResolver2, - (Tcl_ResolveCompiledVarProc*)Itcl_ClassCompiledVarResolver2); -#else Itcl_SetNamespaceResolvers(ooNs, (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver, (Tcl_ResolveVarProc*)Itcl_ClassVarResolver, @@ -446,7 +388,6 @@ (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver, (Tcl_ResolveVarProc*)Itcl_ClassVarResolver, (Tcl_ResolveCompiledVarProc*)Itcl_ClassCompiledVarResolver); -#endif } else { Tcl_SetNamespaceResolver(ooNs, iclsPtr->resolvePtr); Tcl_SetNamespaceResolver(classNs, iclsPtr->resolvePtr); @@ -462,26 +403,26 @@ hPtr = Tcl_CreateHashEntry(&infoPtr->nameClasses, (char *)iclsPtr->fullNamePtr, &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)iclsPtr); + Tcl_SetHashValue(hPtr, iclsPtr); hPtr = Tcl_CreateHashEntry(&infoPtr->namespaceClasses, (char *)classNs, &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)iclsPtr); + Tcl_SetHashValue(hPtr, iclsPtr); if (classNs != ooNs) { hPtr = Tcl_CreateHashEntry(&infoPtr->namespaceClasses, (char *)ooNs, &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)iclsPtr); + Tcl_SetHashValue(hPtr, iclsPtr); if (classNs->clientData && classNs->deleteProc) { (*classNs->deleteProc)(classNs->clientData); } - classNs->clientData = (ClientData)iclsPtr; + classNs->clientData = iclsPtr; classNs->deleteProc = ItclDestroyClass2; } hPtr = Tcl_CreateHashEntry(&infoPtr->classes, (char *)iclsPtr, &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)iclsPtr); + Tcl_SetHashValue(hPtr, iclsPtr); /* * now build the namespace for the common private and protected variables @@ -515,64 +456,44 @@ */ if (iclsPtr->flags & ITCL_TYPE) { namePtr = Tcl_NewStringObj("type", -1); - (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, - (char*)NULL, &ivPtr); + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, + NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_TYPE_VAR; /* mark as "type" variable */ - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)ivPtr); } if (iclsPtr->flags & (ITCL_ECLASS)) { namePtr = Tcl_NewStringObj("win", -1); - (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, - (char*)NULL, &ivPtr); + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, + NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_WIN_VAR; /* mark as "win" variable */ - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)ivPtr); } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { namePtr = Tcl_NewStringObj("self", -1); - (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, - (char*)NULL, &ivPtr); + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, + NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_SELF_VAR; /* mark as "self" variable */ - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)ivPtr); namePtr = Tcl_NewStringObj("selfns", -1); - (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, - (char*)NULL, &ivPtr); + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, + NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_SELFNS_VAR; /* mark as "selfns" variable */ - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)ivPtr); namePtr = Tcl_NewStringObj("win", -1); - (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, - (char*)NULL, &ivPtr); + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, + NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_WIN_VAR; /* mark as "win" variable */ - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)ivPtr); } namePtr = Tcl_NewStringObj("this", -1); - (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, - (char*)NULL, &ivPtr); - + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, + NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_THIS_VAR; /* mark as "this" variable */ - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)ivPtr); - if (infoPtr->currClassFlags & (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET)) { /* @@ -580,17 +501,11 @@ * data members. */ namePtr = Tcl_NewStringObj("itcl_options", -1); - (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, - (char*)NULL, &ivPtr); - + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, + NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_OPTIONS_VAR; /* mark as "itcl_options" * variable */ - - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)ivPtr); - } if (infoPtr->currClassFlags & ITCL_ECLASS) { @@ -599,32 +514,21 @@ * data members. */ namePtr = Tcl_NewStringObj("itcl_option_components", -1); - (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, - (char*)NULL, &ivPtr); - + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, + NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_OPTION_COMP_VAR; /* mark as "itcl_option_components" * variable */ - - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)ivPtr); - } if (infoPtr->currClassFlags & (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { /* * Add the built-in "thiswin" variable to the list of data members. */ namePtr = Tcl_NewStringObj("thiswin", -1); - (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, (char*)NULL, - (char*)NULL, &ivPtr); - + (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, + NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_THIS_VAR; /* mark as "thiswin" variable */ - - hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, - &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)ivPtr); } if (infoPtr->currClassFlags & (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { /* create the itcl_hull component */ @@ -641,13 +545,6 @@ ItclPreserveClass(iclsPtr); iclsPtr->accessCmd = Tcl_GetObjectCommand(oPtr); - cmdNamePtr = Tcl_NewObj(); - Tcl_GetCommandFullName(interp, iclsPtr->accessCmd, cmdNamePtr); - - Tcl_TraceCommand(interp, Tcl_GetString(cmdNamePtr), - TCL_TRACE_DELETE, ClassCmdDeleteTrace, iclsPtr); - - Tcl_DecrRefCount(cmdNamePtr); /* FIXME should set the class objects unknown command to Itcl_HandleClass */ *rPtr = iclsPtr; @@ -683,8 +580,8 @@ Tcl_HashSearch place; ItclClass *iclsPtr2 = NULL; ItclObject *contextIoPtr; - ItclClass *iclsPtr = data[0]; - ItclObjectInfo *infoPtr = data[1]; + ItclClass *iclsPtr = (ItclClass *)data[0]; + ItclObjectInfo *infoPtr = (ItclObjectInfo *)data[1]; void *callbackPtr; int classIsDeleted; @@ -750,8 +647,8 @@ int result) { Tcl_HashEntry *hPtr; - ItclClass *iclsPtr = data[0]; - ItclObjectInfo *infoPtr = data[1]; + ItclClass *iclsPtr = (ItclClass *)data[0]; + ItclObjectInfo *infoPtr = (ItclObjectInfo *)data[1]; int isDerivedReleased; if (result != TCL_OK) { @@ -802,7 +699,7 @@ void *callbackPtr; int result; - infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->classes, (char *)iclsPtr); if (hPtr == NULL) { /* class has already been deleted */ @@ -970,10 +867,10 @@ 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 @@ -989,6 +886,25 @@ } /* + * Now there are no objects and inherited classes anymore, they could access a + * private/protected common variables, so delete the internal namespace. + */ + { + Tcl_DString buffer; + Tcl_Namespace *nsPtr; + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_DStringAppend(&buffer, + (Tcl_GetObjectNamespace(iclsPtr->oPtr))->fullName, -1); + nsPtr = Tcl_FindNamespace(iclsPtr->interp, Tcl_DStringValue(&buffer), NULL, 0); + Tcl_DStringFree(&buffer); + if (nsPtr != NULL) { + Tcl_DeleteNamespace(nsPtr); + } + } + + /* * Next, remove this class from the "derived" list in * all base classes. */ @@ -1100,7 +1016,7 @@ if (hPtr == NULL) { break; } - clookupPtr = Tcl_GetHashValue(hPtr); + clookupPtr = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); ckfree((char *)clookupPtr); Tcl_DeleteHashEntry(hPtr); } @@ -1114,7 +1030,7 @@ if (hPtr == NULL) { break; } - ioptPtr = Tcl_GetHashValue(hPtr); + ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); Itcl_ReleaseData(ioptPtr); } @@ -1125,7 +1041,7 @@ */ FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) { imPtr->iclsPtr = NULL; - ItclReleaseIMF(imPtr); + Itcl_ReleaseData(imPtr); } Tcl_DeleteHashTable(&iclsPtr->functions); @@ -1141,10 +1057,9 @@ * Delete all delegated functions. */ FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { - if (idmPtr->icPtr != NULL) { - if (idmPtr->icPtr->ivPtr->iclsPtr == iclsPtr) { - ItclDeleteDelegatedFunction(idmPtr); - } + if ((idmPtr->icPtr == NULL) + || (idmPtr->icPtr->ivPtr->iclsPtr == iclsPtr)) { + ItclDeleteDelegatedFunction(idmPtr); } } Tcl_DeleteHashTable(&iclsPtr->delegatedFunctions); @@ -1153,11 +1068,11 @@ * Delete all components */ while (1) { - hPtr = Tcl_FirstHashEntry(&iclsPtr->components, &place); - if (hPtr == NULL) { - break; - } - icPtr = Tcl_GetHashValue(hPtr); + hPtr = Tcl_FirstHashEntry(&iclsPtr->components, &place); + if (hPtr == NULL) { + break; + } + icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (icPtr != NULL) { ItclDeleteComponent(icPtr); @@ -1173,7 +1088,7 @@ if (hPtr == NULL) { break; } - ivPtr = Tcl_GetHashValue(hPtr); + ivPtr = (ItclVariable *)Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (ivPtr != NULL) { Itcl_ReleaseData(ivPtr); @@ -1252,7 +1167,7 @@ Tcl_DecrRefCount(iclsPtr->initCode); } - Itcl_ReleaseData((ClientData)iclsPtr->infoPtr); + Itcl_ReleaseData(iclsPtr->infoPtr); Tcl_DecrRefCount(iclsPtr->namePtr); Tcl_DecrRefCount(iclsPtr->fullNamePtr); @@ -1261,7 +1176,7 @@ ckfree((char *)iclsPtr->resolvePtr->clientData); ckfree((char *)iclsPtr->resolvePtr); } - ckfree((char*)iclsPtr); + ckfree(iclsPtr); } @@ -1346,8 +1261,8 @@ Tcl_Namespace* classNs = Itcl_FindClassNamespace(interp, path); if (classNs) { - ItclObjectInfo *infoPtr - = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); + ItclObjectInfo *infoPtr = (ItclObjectInfo *) + Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *) classNs); if (hPtr) { @@ -1380,7 +1295,7 @@ Tcl_AppendResult(interp, "class \"", path, "\" not found in context \"", Tcl_GetCurrentNamespace(interp)->fullName, "\"", - (char*)NULL); + NULL); return NULL; } @@ -1408,9 +1323,9 @@ * ------------------------------------------------------------------------ */ Tcl_Namespace* -Itcl_FindClassNamespace(interp, path) - Tcl_Interp* interp; /* interpreter containing class */ - const char* path; /* path name for class */ +Itcl_FindClassNamespace( + Tcl_Interp* interp, /* interpreter containing class */ + const char* path) /* path name for class */ { Tcl_Namespace* contextNs = Tcl_GetCurrentNamespace(interp); Tcl_Namespace *classNs = Tcl_FindNamespace(interp, path, NULL, 0); @@ -1436,8 +1351,8 @@ Tcl_Interp *interp, int result) { - Tcl_Obj *objNamePtr = data[0]; - ItclClass *iclsPtr = data[1]; + Tcl_Obj *objNamePtr = (Tcl_Obj *)data[0]; + ItclClass *iclsPtr = (ItclClass *)data[1]; if (result == TCL_OK) { if (!(iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR))) { Tcl_ResetResult(interp); @@ -1454,10 +1369,10 @@ Tcl_Interp *interp, int result) { - Tcl_Obj *objNamePtr = data[0]; - ItclClass *iclsPtr = data[1]; + Tcl_Obj *objNamePtr = (Tcl_Obj *)data[0]; + ItclClass *iclsPtr = (ItclClass *)data[1]; int objc = PTR2INT(data[2]); - Tcl_Obj **objv = data[3]; + Tcl_Obj **objv = (Tcl_Obj **)data[3]; if (result == TCL_OK) { result = ItclCreateObject(interp, Tcl_GetString(objNamePtr), iclsPtr, @@ -1469,7 +1384,7 @@ * ------------------------------------------------------------------------ * Itcl_HandleClass() * - * first argument is ::itcl::parser::handleClass + * first argument is ::itcl::parser::handleClass * Invoked by Tcl whenever the user issues the command associated with * a class name. Handles the following syntax: * @@ -1586,7 +1501,7 @@ Tcl_GetString(objv[1]), "\"", NULL); return TCL_ERROR; } - iclsPtr = Tcl_GetHashValue(hPtr); + iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); /* * If the object name is "::", and if this is an old-style class @@ -1608,7 +1523,7 @@ " ", Tcl_GetString(objv[1]), "::", Tcl_GetString(objv[4]), " ?args?", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -1693,6 +1608,209 @@ /* * ------------------------------------------------------------------------ + * ItclResolveVarEntry() + * + * Side effect: (re)build part of resolver hash-table on demand. + * ------------------------------------------------------------------------ + */ +Tcl_HashEntry * +ItclResolveVarEntry( + ItclClass* iclsPtr, /* class definition where to resolve variable */ + const char *lookupName) /* name of variable being resolved */ +{ + Tcl_HashEntry *reshPtr, *hPtr; + + /* could be resolved directly */ + if ((reshPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, lookupName)) != NULL) { + return reshPtr; + } else { + /* try to build virtual table for this var */ + const char *varName, *simpleName; + Tcl_DString buffer, buffer2, *bufferC; + ItclHierIter hier; + ItclClass* iclsPtr2; + ItclVarLookup *vlookup; + ItclVariable *ivPtr; + Tcl_Namespace* nsPtr; + Tcl_Obj *vnObjPtr; + int newEntry, processAncestors; + size_t varLen; + + /* (de)qualify to simple name */ + varName = simpleName = lookupName; + while(*varName) { + if (*varName++ == ':') { + if (*varName++ == ':') { simpleName = varName; } + }; + } + vnObjPtr = Tcl_NewStringObj(simpleName, -1); + + processAncestors = simpleName != lookupName; + + Tcl_DStringInit(&buffer); + Tcl_DStringInit(&buffer2); + + /* + * Scan through all classes in the hierarchy, from most to + * least specific. Add a lookup entry for each variable + * into the table. + */ + Itcl_InitHierIter(&hier, iclsPtr); + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + while (iclsPtr2 != NULL) { + + hPtr = Tcl_FindHashEntry(&iclsPtr2->variables, vnObjPtr); + if (hPtr) { + ivPtr = (ItclVariable*)Tcl_GetHashValue(hPtr); + + vlookup = NULL; + + /* + * Create all possible names for this variable and enter + * them into the variable resolution table: + * var + * class::var + * namesp1::class::var + * namesp2::namesp1::class::var + * ... + */ + varName = simpleName; varLen = -1; + bufferC = &buffer; + nsPtr = iclsPtr2->nsPtr; + + while (1) { + hPtr = Tcl_CreateHashEntry(&iclsPtr->resolveVars, + varName, &newEntry); + + /* check for same name in current class */ + if (!newEntry) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + if (vlookup->ivPtr != ivPtr && iclsPtr2 == iclsPtr) { + /* if used multiple times - unbind, else - overwrite */ + if (vlookup->usage > 1) { + /* correct leastQualName */ + vlookup->leastQualName = NULL; + processAncestors = 1; /* correction in progress */ + /* should create new lookup */ + --vlookup->usage; + vlookup = NULL; + } else { + /* correct values (overwrite) */ + vlookup->usage = 0; + goto setResVar; + } + newEntry = 1; + } else { + /* var exists and no correction necessary - next var */ + if (!processAncestors) { + break; + } + /* check leastQualName correction needed */ + if (!vlookup->leastQualName) { + vlookup->leastQualName = + Tcl_GetHashKey(&iclsPtr->resolveVars, hPtr); + } + /* reset vlookup for full-qualified names - new lookup */ + if (vlookup->ivPtr != ivPtr) { + vlookup = NULL; + } + } + } + if (newEntry) { + if (!vlookup) { + /* create new (or overwrite) */ + vlookup = (ItclVarLookup *)ckalloc(sizeof(ItclVarLookup)); + vlookup->usage = 0; + + setResVar: + + vlookup->ivPtr = ivPtr; + vlookup->leastQualName = + Tcl_GetHashKey(&iclsPtr->resolveVars, hPtr); + + /* + * If this variable is PRIVATE to another class scope, + * then mark it as "inaccessible". + */ + vlookup->accessible = (ivPtr->protection != ITCL_PRIVATE || + ivPtr->iclsPtr == iclsPtr); + + /* + * Set aside the first object-specific slot for the built-in + * "this" variable. Only allocate one of these, even though + * there is a definition for "this" in each class scope. + * Set aside the second and third object-specific slot for the built-in + * "itcl_options" and "itcl_option_components" variable. + */ + if (!iclsPtr->numInstanceVars) { + iclsPtr->numInstanceVars += 3; + } + /* + * If this is a reference to the built-in "this" + * variable, then its index is "0". Otherwise, + * add another slot to the end of the table. + */ + if ((ivPtr->flags & ITCL_THIS_VAR) != 0) { + vlookup->varNum = 0; + } else { + if ((ivPtr->flags & ITCL_OPTIONS_VAR) != 0) { + vlookup->varNum = 1; + } else { + vlookup->varNum = iclsPtr->numInstanceVars++; + } + } + } + + Tcl_SetHashValue(hPtr, vlookup); + vlookup->usage++; + } + + /* if we have found it */ + if (simpleName == lookupName || strcmp(varName, lookupName) == 0) { + if (!reshPtr) { + reshPtr = hPtr; + } + break; + } + if (nsPtr == NULL) { + break; + } + Tcl_DStringSetLength(bufferC, 0); + Tcl_DStringAppend(bufferC, nsPtr->name, -1); + Tcl_DStringAppend(bufferC, "::", 2); + Tcl_DStringAppend(bufferC, varName, varLen); + varName = Tcl_DStringValue(bufferC); + varLen = Tcl_DStringLength(bufferC); + bufferC = (bufferC == &buffer) ? &buffer2 : &buffer; + + nsPtr = nsPtr->parentPtr; + } + + } + + /* Stop create vars for ancestors (if not needed) */ + if (!processAncestors && reshPtr) { + /* simple name - don't need to check ancestors */ + break; + } + + iclsPtr2 = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + Tcl_DStringFree(&buffer); + Tcl_DStringFree(&buffer2); + Tcl_DecrRefCount(vnObjPtr); + + if (reshPtr == NULL) { + reshPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, lookupName); + } + return reshPtr; + } +} + +/* + * ------------------------------------------------------------------------ * Itcl_BuildVirtualTables() * * Invoked whenever the class heritage changes or members are added or @@ -1703,7 +1821,7 @@ * Used primarily in Itcl_ClassCmdResolver() to resolve all * command references in a namespace. * - * DATA MEMBERS: resolveVars + * DATA MEMBERS: resolveVars (built on demand, moved to ItclResolveVarEntry) * Used primarily in Itcl_ClassVarResolver() to quickly resolve * variable references in each class scope. * @@ -1721,170 +1839,19 @@ Tcl_HashEntry *hPtr; Tcl_HashSearch place; Tcl_Namespace* nsPtr; - Tcl_DString buffer, buffer2; + Tcl_DString buffer, buffer2, *bufferC, *bufferC2, *bufferSwp; Tcl_Obj *objPtr; - ItclVarLookup *vlookup; - ItclVariable *ivPtr; ItclMemberFunc *imPtr; ItclDelegatedFunction *idmPtr; ItclHierIter hier; ItclClass *iclsPtr2; ItclCmdLookup *clookupPtr; -#ifdef NEW_PROTO_RESOLVER - ItclClassVarInfo *icviPtr; - ItclClassCmdInfo *icciPtr; -#endif int newEntry; Tcl_DStringInit(&buffer); Tcl_DStringInit(&buffer2); /* - * Clear the variable resolution table. - */ - hPtr = Tcl_FirstHashEntry(&iclsPtr->resolveVars, &place); - while (hPtr) { - vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); - if (--vlookup->usage == 0) { - ckfree((char*)vlookup); - } - hPtr = Tcl_NextHashEntry(&place); - } - Tcl_DeleteHashTable(&iclsPtr->resolveVars); - Tcl_InitHashTable(&iclsPtr->resolveVars, TCL_STRING_KEYS); - iclsPtr->numInstanceVars = 0; - - /* - * Set aside the first object-specific slot for the built-in - * "this" variable. Only allocate one of these, even though - * there is a definition for "this" in each class scope. - * Set aside the second and third object-specific slot for the built-in - * "itcl_options" and "itcl_option_components" variable. - */ - iclsPtr->numInstanceVars++; - iclsPtr->numInstanceVars++; - iclsPtr->numInstanceVars++; - - /* - * Scan through all classes in the hierarchy, from most to - * least specific. Add a lookup entry for each variable - * into the table. - */ - Itcl_InitHierIter(&hier, iclsPtr); - iclsPtr2 = Itcl_AdvanceHierIter(&hier); - while (iclsPtr2 != NULL) { - hPtr = Tcl_FirstHashEntry(&iclsPtr2->variables, &place); - while (hPtr) { -#ifdef NEW_PROTO_RESOLVER - int type = VAR_TYPE_VARIABLE; -#endif - ivPtr = (ItclVariable*)Tcl_GetHashValue(hPtr); - - vlookup = (ItclVarLookup *)ckalloc(sizeof(ItclVarLookup)); - vlookup->ivPtr = ivPtr; - vlookup->usage = 0; - vlookup->leastQualName = NULL; - - /* - * If this variable is PRIVATE to another class scope, - * then mark it as "inaccessible". - */ - vlookup->accessible = (ivPtr->protection != ITCL_PRIVATE || - ivPtr->iclsPtr == iclsPtr); - - if (ivPtr->flags & ITCL_COMMON) { -#ifdef NEW_PROTO_RESOLVER - type = VAR_TYPE_COMMON; -#endif - } - /* - * If this is a reference to the built-in "this" - * variable, then its index is "0". Otherwise, - * add another slot to the end of the table. - */ - if ((ivPtr->flags & ITCL_THIS_VAR) != 0) { - vlookup->varNum = 0; - } else { - if ((ivPtr->flags & ITCL_OPTIONS_VAR) != 0) { - vlookup->varNum = 1; - } else { - vlookup->varNum = iclsPtr->numInstanceVars++; - } - } -#ifdef NEW_PROTO_RESOLVER - icviPtr = (ItclClassVarInfo *)ckalloc( - sizeof(ItclClassVarInfo)); - icviPtr->type = type; - icviPtr->protection = ivPtr->protection; - icviPtr->nsPtr = iclsPtr->nsPtr; - icviPtr->declaringNsPtr = iclsPtr2->nsPtr; - icviPtr->varNum = vlookup->varNum; - ClientData clientData2; - clientData2 = Itcl_RegisterClassVariable( - iclsPtr->infoPtr->interp, iclsPtr2->nsPtr, - Tcl_GetString(ivPtr->namePtr), icviPtr); - vlookup->classVarInfoPtr = clientData2; -#endif -/* FIXME !!! should use for var lookup !! */ - - /* - * Create all possible names for this variable and enter - * them into the variable resolution table: - * var - * class::var - * namesp1::class::var - * namesp2::namesp1::class::var - * ... - */ - Tcl_DStringSetLength(&buffer, 0); - Tcl_DStringAppend(&buffer, Tcl_GetString(ivPtr->namePtr), -1); - nsPtr = iclsPtr2->nsPtr; - - while (1) { - hPtr = Tcl_CreateHashEntry(&iclsPtr->resolveVars, - Tcl_DStringValue(&buffer), &newEntry); - - if (newEntry) { - Tcl_SetHashValue(hPtr, (ClientData)vlookup); - vlookup->usage++; - - if (!vlookup->leastQualName) { - vlookup->leastQualName = - Tcl_GetHashKey(&iclsPtr->resolveVars, hPtr); - } -#ifdef NEW_PROTO_RESOLVER - Itcl_RegisterClassVariable(iclsPtr->infoPtr->interp, - iclsPtr->nsPtr, Tcl_DStringValue(&buffer), - vlookup->classVarInfoPtr); -#endif - } - - if (nsPtr == NULL) { - break; - } - Tcl_DStringSetLength(&buffer2, 0); - Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1); - Tcl_DStringSetLength(&buffer, 0); - Tcl_DStringAppend(&buffer, nsPtr->name, -1); - Tcl_DStringAppend(&buffer, "::", -1); - Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1); - - nsPtr = nsPtr->parentPtr; - } - - /* - * If this record is not needed, free it now. - */ - if (vlookup->usage == 0) { - ckfree((char*)vlookup); - } - hPtr = Tcl_NextHashEntry(&place); - } - iclsPtr2 = Itcl_AdvanceHierIter(&hier); - } - Itcl_DeleteHierIter(&hier); - - /* * Clear the command resolution table. */ while (1) { @@ -1922,10 +1889,12 @@ */ Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, Tcl_GetString(imPtr->namePtr), -1); + bufferC = &buffer; bufferC2 = &buffer2; nsPtr = iclsPtr2->nsPtr; while (1) { - objPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1); + objPtr = Tcl_NewStringObj(Tcl_DStringValue(bufferC), + Tcl_DStringLength(bufferC)); hPtr = Tcl_CreateHashEntry(&iclsPtr->resolveCmds, (char *)objPtr, &newEntry); @@ -1933,25 +1902,7 @@ clookupPtr = (ItclCmdLookup *)ckalloc(sizeof(ItclCmdLookup)); memset(clookupPtr, 0, sizeof(ItclCmdLookup)); clookupPtr->imPtr = imPtr; - Tcl_SetHashValue(hPtr, (ClientData)clookupPtr); -#ifdef NEW_PROTO_RESOLVER - int type = CMD_TYPE_METHOD; - if (imPtr->flags & ITCL_COMMON) { - type = CMD_TYPE_PROC; - } - icciPtr = (ItclClassCmdInfo *)ckalloc( - sizeof(ItclClassCmdInfo)); - icciPtr->type = type; - icciPtr->protection = imPtr->protection; - icciPtr->nsPtr = iclsPtr->nsPtr; - icciPtr->declaringNsPtr = iclsPtr2->nsPtr; - ClientData clientData2; - clientData2 = Itcl_RegisterClassCommand( - iclsPtr->infoPtr->interp, iclsPtr->nsPtr, - Tcl_GetString(imPtr->namePtr), icciPtr); - clookupPtr->classCmdInfoPtr = clientData2; - clookupPtr->cmdPtr = imPtr->accessCmd; -#endif + Tcl_SetHashValue(hPtr, clookupPtr); } else { Tcl_DecrRefCount(objPtr); } @@ -1959,12 +1910,13 @@ if (nsPtr == NULL) { break; } - Tcl_DStringSetLength(&buffer2, 0); - Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1); - Tcl_DStringSetLength(&buffer, 0); - Tcl_DStringAppend(&buffer, nsPtr->name, -1); - Tcl_DStringAppend(&buffer, "::", -1); - Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1); + + Tcl_DStringSetLength(bufferC2, 0); + Tcl_DStringAppend(bufferC2, nsPtr->name, -1); + Tcl_DStringAppend(bufferC2, "::", 2); + Tcl_DStringAppend(bufferC2, Tcl_DStringValue(bufferC), + Tcl_DStringLength(bufferC)); + bufferSwp = bufferC; bufferC = bufferC2; bufferC2 = bufferSwp; nsPtr = nsPtr->parentPtr; } @@ -2041,7 +1993,7 @@ "variable name \"", Tcl_GetString(namePtr), "\" already defined in class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -2050,22 +2002,21 @@ * its implementation. */ if (config) { - if (Itcl_CreateMemberCode(interp, iclsPtr, (char*)NULL, 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); @@ -2089,9 +2040,9 @@ ivPtr->init = NULL; } - Tcl_SetHashValue(hPtr, (ClientData)ivPtr); - Itcl_PreserveData((ClientData)ivPtr); - Itcl_EventuallyFree((ClientData)ivPtr, Itcl_DeleteVariable); + Tcl_SetHashValue(hPtr, ivPtr); + Itcl_PreserveData(ivPtr); + Itcl_EventuallyFree(ivPtr, (Tcl_FreeProc *) Itcl_DeleteVariable); *ivPtrPtr = ivPtr; return TCL_OK; @@ -2131,7 +2082,7 @@ "option name \"", Tcl_GetString(ioptPtr->namePtr), "\" already defined in class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -2143,18 +2094,18 @@ Tcl_AppendToObj(ioptPtr->fullNamePtr, "::", 2); Tcl_AppendToObj(ioptPtr->fullNamePtr, Tcl_GetString(ioptPtr->namePtr), -1); Tcl_IncrRefCount(ioptPtr->fullNamePtr); - Tcl_SetHashValue(hPtr, (ClientData)ioptPtr); - Itcl_PreserveData((ClientData)ioptPtr); - Itcl_EventuallyFree((ClientData)ioptPtr, ItclDeleteOption); + Tcl_SetHashValue(hPtr, ioptPtr); + Itcl_PreserveData(ioptPtr); + Itcl_EventuallyFree(ioptPtr, (Tcl_FreeProc *) ItclDeleteOption); return TCL_OK; } /* * ------------------------------------------------------------------------ - * Itcl_CreateMethodVariable() + * ItclCreateMethodVariable(), Itcl_CreateMethodVariable() * * Creates a new class methdovariable definition. If this is a public - * methodvariable, + * methodvariable, * * Returns TCL_ERROR along with an error message in the specified * interpreter if anything goes wrong. Otherwise, this returns @@ -2162,10 +2113,9 @@ * ------------------------------------------------------------------------ */ int -Itcl_CreateMethodVariable( +ItclCreateMethodVariable( Tcl_Interp *interp, /* interpreter managing this transaction */ - ItclClass* iclsPtr, /* class containing this variable */ - Tcl_Obj* namePtr, /* variable name */ + ItclVariable *ivPtr, /* variable reference (from Itcl_CreateVariable) */ Tcl_Obj* defaultPtr, /* initial value */ Tcl_Obj* callbackPtr, /* code invoked when variable is set */ ItclMethodVariable** imvPtrPtr) @@ -2179,31 +2129,27 @@ * Add this methodvariable to the options table for the class. * Make sure that the methodvariable name does not already exist. */ - hPtr = Tcl_CreateHashEntry(&iclsPtr->methodVariables, - (char *)namePtr, &isNew); + hPtr = Tcl_CreateHashEntry(&ivPtr->iclsPtr->methodVariables, + (char *)ivPtr->namePtr, &isNew); if (!isNew) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "methdovariable name \"", Tcl_GetString(namePtr), + "methdovariable name \"", Tcl_GetString(ivPtr->namePtr), "\" already defined in class \"", - Tcl_GetString (iclsPtr->fullNamePtr), "\"", - (char*)NULL); + Tcl_GetString (ivPtr->iclsPtr->fullNamePtr), "\"", + NULL); return TCL_ERROR; } - Tcl_IncrRefCount(namePtr); /* * If everything looks good, create the option definition. */ imvPtr = (ItclMethodVariable*)ckalloc(sizeof(ItclMethodVariable)); memset(imvPtr, 0, sizeof(ItclMethodVariable)); - imvPtr->iclsPtr = iclsPtr; + imvPtr->iclsPtr = ivPtr->iclsPtr; imvPtr->protection = Itcl_Protection(interp, 0); - imvPtr->namePtr = namePtr; + imvPtr->namePtr = ivPtr->namePtr; Tcl_IncrRefCount(imvPtr->namePtr); - imvPtr->fullNamePtr = Tcl_NewStringObj( - Tcl_GetString(iclsPtr->fullNamePtr), -1); - Tcl_AppendToObj(imvPtr->fullNamePtr, "::", 2); - Tcl_AppendToObj(imvPtr->fullNamePtr, Tcl_GetString(namePtr), -1); + imvPtr->fullNamePtr = ivPtr->fullNamePtr; Tcl_IncrRefCount(imvPtr->fullNamePtr); imvPtr->defaultValuePtr = defaultPtr; if (defaultPtr != NULL) { @@ -2218,13 +2164,11 @@ imvPtr->protection = ITCL_PROTECTED; } - Tcl_SetHashValue(hPtr, (ClientData)imvPtr); + Tcl_SetHashValue(hPtr, imvPtr); *imvPtrPtr = imvPtr; return TCL_OK; } - - /* * ------------------------------------------------------------------------ @@ -2271,7 +2215,7 @@ if (hPtr == NULL) { return NULL; } - ivPtr = Tcl_GetHashValue(hPtr); + ivPtr = (ItclVariable *)Tcl_GetHashValue(hPtr); /* * Activate the namespace for the given class. That installs * the appropriate name resolution rules and by-passes any @@ -2290,7 +2234,7 @@ oPtr = Tcl_GetObjectFromObj(interp, classObjPtr); if (oPtr) { - ItclClass *iclsPtr = Tcl_ObjectGetMetadata(oPtr, + ItclClass *iclsPtr = (ItclClass *)Tcl_ObjectGetMetadata(oPtr, contextIclsPtr->infoPtr->class_meta_type); if (iclsPtr) { @@ -2326,7 +2270,7 @@ Tcl_DStringAppend(&buffer, lastCp, -1); val = Tcl_GetVar2(interp, (const char *)Tcl_DStringValue(&buffer), - (char*)NULL, 0); + NULL, 0); Tcl_DStringFree(&buffer); return val; } @@ -2342,12 +2286,12 @@ * ------------------------------------------------------------------------ */ void -Itcl_InitHierIter(iter,iclsPtr) - ItclHierIter *iter; /* iterator used for traversal */ - ItclClass *iclsPtr; /* class definition for start of traversal */ +Itcl_InitHierIter( + ItclHierIter *iter, /* iterator used for traversal */ + ItclClass *iclsPtr) /* class definition for start of traversal */ { Itcl_InitStack(&iter->stack); - Itcl_PushStack((ClientData)iclsPtr, &iter->stack); + Itcl_PushStack(iclsPtr, &iter->stack); iter->current = iclsPtr; } @@ -2360,8 +2304,8 @@ * ------------------------------------------------------------------------ */ void -Itcl_DeleteHierIter(iter) - ItclHierIter *iter; /* iterator used for traversal */ +Itcl_DeleteHierIter( + ItclHierIter *iter) /* iterator used for traversal */ { Itcl_DeleteStack(&iter->stack); iter->current = NULL; @@ -2380,7 +2324,7 @@ Itcl_AdvanceHierIter( ItclHierIter *iter) /* iterator used for traversal */ { - register Itcl_ListElem *elem; + Itcl_ListElem *elem; ItclClass *iclsPtr; iter->current = (ItclClass*)Itcl_PopStack(&iter->stack); @@ -2416,8 +2360,6 @@ ItclVariable *ivPtr; ivPtr = (ItclVariable *)cdata; -if (ivPtr->arrayInitPtr != NULL) { -} hPtr = Tcl_FindHashEntry(&ivPtr->infoPtr->classes, (char *)ivPtr->iclsPtr); if (hPtr != NULL) { /* unlink owerself from list of class variables */ @@ -2428,7 +2370,7 @@ } } if (ivPtr->codePtr != NULL) { - ItclReleaseMemberCode(ivPtr->codePtr); + Itcl_ReleaseData(ivPtr->codePtr); } Tcl_DecrRefCount(ivPtr->namePtr); Tcl_DecrRefCount(ivPtr->fullNamePtr); @@ -2438,7 +2380,7 @@ if (ivPtr->arrayInitPtr) { Tcl_DecrRefCount(ivPtr->arrayInitPtr); } - ckfree((char*)ivPtr); + Itcl_Free(ivPtr); } /* @@ -2466,7 +2408,7 @@ } if (ioptPtr->codePtr) { - ItclReleaseMemberCode(ioptPtr->codePtr); + Itcl_ReleaseData(ioptPtr->codePtr); } if (ioptPtr->defaultValuePtr != NULL) { Tcl_DecrRefCount(ioptPtr->defaultValuePtr); @@ -2490,7 +2432,7 @@ Tcl_DecrRefCount(ioptPtr->validateMethodVarPtr); } Itcl_ReleaseData(ioptPtr->idoPtr); - ckfree((char*)ioptPtr); + Itcl_Free(ioptPtr); } /* @@ -2506,13 +2448,11 @@ { Tcl_HashEntry *hPtr; -if (imPtr->iclsPtr) { - hPtr = Tcl_FindHashEntry(&imPtr->iclsPtr->infoPtr->procMethods, + hPtr = Tcl_FindHashEntry(&imPtr->infoPtr->procMethods, (char *) imPtr->tmPtr); if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } -} hPtr = Tcl_FindHashEntry(&imPtr->infoPtr->classes, (char *)imPtr->iclsPtr); if (hPtr != NULL) { /* unlink owerself from list of class functions */ @@ -2523,7 +2463,7 @@ } } if (imPtr->codePtr != NULL) { - ItclReleaseMemberCode(imPtr->codePtr); + Itcl_ReleaseData(imPtr->codePtr); } Tcl_DecrRefCount(imPtr->namePtr); Tcl_DecrRefCount(imPtr->fullNamePtr); @@ -2545,7 +2485,7 @@ if (imPtr->argListPtr != NULL) { ItclDeleteArgList(imPtr->argListPtr); } - ckfree((char*)imPtr); + Itcl_Free(imPtr); } /* @@ -2606,7 +2546,7 @@ } } Tcl_DeleteHashTable(&idoPtr->exceptions); - ckfree((char *)idoPtr); + Itcl_Free(idoPtr); } /* diff -Nru itcl4-4.1.2/generic/itclCmd.c itcl4-4.2.0/generic/itclCmd.c --- itcl4-4.1.2/generic/itclCmd.c 2017-12-08 13:09:27.000000000 +0000 +++ itcl4-4.2.0/generic/itclCmd.c 2019-11-03 02:24:15.000000000 +0000 @@ -55,9 +55,9 @@ ItclClass *iclsPtr; ItclShowArgs(1, "NRThisCmd", objc, objv); - iclsPtr = clientData; + iclsPtr = (ItclClass *)clientData; clientData2 = Itcl_GetCallFrameClientData(interp); - oPtr = Tcl_ObjectContextObject(clientData2); + oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)clientData2); return Itcl_PublicObjectCmd(oPtr, interp, iclsPtr->clsPtr, objc, objv); } /* ARGSUSED */ @@ -82,14 +82,14 @@ return Itcl_SelfCmd(clientData,interp, objc, objv); } ItclShowArgs(1, "Itcl_ThisCmd", objc, objv); - iclsPtr = clientData; + iclsPtr = (ItclClass *)clientData; clientData2 = Itcl_GetCallFrameClientData(interp); if (clientData2 == NULL) { Tcl_AppendResult(interp, "this cannot be invoked without an object context", NULL); return TCL_ERROR; } - oPtr = Tcl_ObjectContextObject(clientData2); + oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)clientData2); if (oPtr == NULL) { Tcl_AppendResult(interp, "this cannot be invoked without an object context", NULL); @@ -211,14 +211,14 @@ */ Itcl_InitStack(&search); - Itcl_PushStack((ClientData)globalNs, &search); - Itcl_PushStack((ClientData)activeNs, &search); /* last in, first out! */ + Itcl_PushStack(globalNs, &search); + Itcl_PushStack(activeNs, &search); /* last in, first out! */ Tcl_InitHashTable(&unique, TCL_ONE_WORD_KEYS); handledActiveNs = 0; while (Itcl_GetStackSize(&search) > 0) { - nsPtr = Itcl_PopStack(&search); + nsPtr = (Tcl_Namespace *)Itcl_PopStack(&search); if (nsPtr == activeNs && handledActiveNs) { continue; } @@ -242,7 +242,7 @@ if (forceFullNames || nsPtr != activeNs || originalCmd != NULL) { - objPtr = Tcl_NewStringObj((char*)NULL, 0); + objPtr = Tcl_NewStringObj(NULL, 0); Tcl_GetCommandFullName(interp, cmd, objPtr); cmdName = Tcl_GetString(objPtr); } else { @@ -257,8 +257,8 @@ if (newEntry && ((pattern == NULL) || - Tcl_StringMatch((const char *)cmdName, pattern))) { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + Tcl_StringCaseMatch((const char *)cmdName, pattern, 0))) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), objPtr); } else { /* if not appended to the result, free objPtr. */ @@ -393,14 +393,14 @@ */ Itcl_InitStack(&search); - Itcl_PushStack((ClientData)globalNs, &search); - Itcl_PushStack((ClientData)activeNs, &search); /* last in, first out! */ + Itcl_PushStack(globalNs, &search); + Itcl_PushStack(activeNs, &search); /* last in, first out! */ Tcl_InitHashTable(&unique, TCL_ONE_WORD_KEYS); handledActiveNs = 0; while (Itcl_GetStackSize(&search) > 0) { - nsPtr = Itcl_PopStack(&search); + nsPtr = (Tcl_Namespace *)Itcl_PopStack(&search); if (nsPtr == activeNs && handledActiveNs) { continue; } @@ -428,7 +428,7 @@ if (forceFullNames || nsPtr != activeNs || originalCmd != NULL) { - objPtr = Tcl_NewStringObj((char*)NULL, 0); + objPtr = Tcl_NewStringObj(NULL, 0); Tcl_GetCommandFullName(interp, cmd, objPtr); cmdName = Tcl_GetString(objPtr); } else { @@ -440,8 +440,8 @@ match = 0; if (newEntry && - (!pattern || Tcl_StringMatch((const char *)cmdName, - pattern))) { + (!pattern || Tcl_StringCaseMatch((const char *)cmdName, + pattern, 0))) { if ((iclsPtr == NULL) || (contextIoPtr->iclsPtr == iclsPtr)) { if (isaDefn == NULL) { @@ -459,7 +459,7 @@ } if (match) { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), objPtr); } else { Tcl_DecrRefCount(objPtr); /* throw away the name */ @@ -572,7 +572,7 @@ Tcl_Interp *interp, int result) { - ItclObject *contextIoPtr = data[0]; + ItclObject *contextIoPtr = (ItclObject *)data[0]; if (contextIoPtr->destructorHasBeenCalled) { Tcl_AppendResult(interp, "can't delete an object while it is being ", "destructed", NULL); @@ -604,7 +604,7 @@ * abort with an error. */ for (i=1; i < objc; i++) { - name = Tcl_GetStringFromObj(objv[i], (int*)NULL); + name = Tcl_GetString(objv[i]); contextIoPtr = NULL; if (Itcl_FindObject(interp, name, &contextIoPtr) != TCL_OK) { return TCL_ERROR; @@ -613,7 +613,7 @@ if (contextIoPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "object \"", name, "\" not found", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -676,7 +676,6 @@ Tcl_Namespace *contextNsPtr; Tcl_HashEntry *hPtr; Tcl_Object oPtr; - Tcl_InterpDeleteProc *procPtr; Tcl_Obj *objPtr2; Tcl_Var var; Tcl_HashEntry *entry; @@ -685,7 +684,7 @@ ItclObjectInfo *infoPtr; ItclVarLookup *vlookup; char *openParen; - register char *p; + char *p; char *token; int doAppend; int result; @@ -703,7 +702,7 @@ * If this looks like a fully qualified name already, * then return it as is. */ - token = Tcl_GetStringFromObj(objv[1], (int*)NULL); + token = Tcl_GetString(objv[1]); if (*token == ':' && *(token+1) == ':') { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; @@ -740,7 +739,7 @@ contextIoPtr = NULL; contextIclsPtr = NULL; oPtr = NULL; - infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, &procPtr); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)contextNsPtr); if (hPtr != NULL) { contextIclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); @@ -748,12 +747,12 @@ if (Itcl_IsClassNamespace(contextNsPtr)) { ClientData clientData; - entry = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, token); + entry = ItclResolveVarEntry(contextIclsPtr, token); if (!entry) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "variable \"", token, "\" not found in class \"", Tcl_GetString(contextIclsPtr->fullNamePtr), "\"", - (char*)NULL); + NULL); result = TCL_ERROR; goto scopeCmdDone; } @@ -798,7 +797,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't scope variable \"", token, "\": missing object context", - (char*)NULL); + NULL); result = TCL_ERROR; goto scopeCmdDone; } @@ -810,7 +809,7 @@ } } - objPtr2 = Tcl_NewStringObj((char*)NULL, 0); + objPtr2 = Tcl_NewStringObj(NULL, 0); Tcl_IncrRefCount(objPtr2); Tcl_AppendToObj(objPtr2, ITCL_VARIABLES_NAMESPACE, -1); Tcl_AppendToObj(objPtr2, @@ -853,7 +852,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "variable \"", token, "\" not found in namespace \"", contextNsPtr->fullName, "\"", - (char*)NULL); + NULL); result = TCL_ERROR; goto scopeCmdDone; } @@ -914,7 +913,7 @@ * Handle flags like "-namespace"... */ for (pos=1; pos < objc; pos++) { - token = Tcl_GetStringFromObj(objv[pos], (int*)NULL); + token = Tcl_GetString(objv[pos]); if (*token != '-') { break; } @@ -927,7 +926,7 @@ } else { token = Tcl_GetString(objv[pos+1]); contextNs = Tcl_FindNamespace(interp, token, - (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); + NULL, TCL_LEAVE_ERR_MSG); if (!contextNs) { return TCL_ERROR; @@ -941,7 +940,7 @@ } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option \"", token, "\": should be -namespace or --", - (char*)NULL); + NULL); return TCL_ERROR; } } @@ -958,7 +957,7 @@ * current namespace context, and appending the remaining * arguments AS A LIST... */ - listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + listPtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("namespace", -1)); @@ -978,8 +977,7 @@ objPtr = Tcl_NewListObj(objc-pos, &objv[pos]); } Tcl_ListObjAppendElement(interp, listPtr, objPtr); - Tcl_SetResult(interp, Tcl_GetString(listPtr), TCL_VOLATILE); - Tcl_DecrRefCount(listPtr); + Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -1048,7 +1046,7 @@ } } /* end for objc loop */ - + /* * The object name may be a scoped value of the form @@ -1066,7 +1064,7 @@ * Need the NULL test, or the test will fail if cmd is NULL */ if (cmd == NULL || ! Itcl_IsObject(cmd)) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); ckfree((char *)cmdName); return TCL_OK; } @@ -1084,7 +1082,7 @@ contextIoPtr = iclsPtr->infoPtr->currIoPtr; } if (! Itcl_ObjectIsa(contextIoPtr, iclsPtr)) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); ckfree((char *)cmdName); return TCL_OK; } @@ -1094,7 +1092,7 @@ /* * Got this far, so assume that it is a valid object */ - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); ckfree(cmdName); return TCL_OK; @@ -1154,9 +1152,9 @@ * isn't a class */ if (iclsPtr != NULL) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); } else { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); } ckfree(cname); @@ -1236,7 +1234,7 @@ * ------------------------------------------------------------------------ * Itcl_ForwardAddCmd() * - * Used to similar to iterp alias to forward the call of a method + * Used to similar to iterp alias to forward the call of a method * to another method within the class * * Returns TCL_OK/TCL_ERROR to indicate success/failure. @@ -1260,7 +1258,7 @@ Tcl_WrongNumArgs(interp, 1, objv, " ? ...?"); return TCL_ERROR; } - infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); if (iclsPtr == NULL) { Tcl_HashEntry *hPtr; @@ -1270,7 +1268,7 @@ "\" not found", NULL); return TCL_ERROR; } - iclsPtr = Tcl_GetHashValue(hPtr); + iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); } prefixObj = Tcl_NewListObj(objc-2, objv+2); mPtr = Itcl_NewForwardClassMethod(interp, iclsPtr->clsPtr, 1, @@ -1433,7 +1431,7 @@ infoPtr = (ItclObjectInfo *)clientData; ItclShowArgs(1, "Itcl_AddOptionCmd", objc, objv); if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, + Tcl_WrongNumArgs(interp, 1, objv, "className protection option optionName ..."); return TCL_ERROR; } @@ -1443,7 +1441,7 @@ "\" not found", NULL); return TCL_ERROR; } - iclsPtr = Tcl_GetHashValue(hPtr); + iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); protectionStr = Tcl_GetString(objv[2]); pLevel = -1; if (strcmp(protectionStr, "public") == 0) { @@ -1460,7 +1458,7 @@ NULL); return TCL_ERROR; } - Itcl_PushStack((ClientData)iclsPtr, &infoPtr->clsStack); + Itcl_PushStack(iclsPtr, &infoPtr->clsStack); result = Itcl_ClassOptionCmd(clientData, interp, objc-2, objv+2); Itcl_PopStack(&infoPtr->clsStack); if (result != TCL_OK) { @@ -1476,7 +1474,7 @@ * * Used to build an option for an [incr Tcl] object * - * Syntax: ::itcl::addobjectoption option + * Syntax: ::itcl::addobjectoption option * ?-default ? * ?-configuremethod ? * ?-validatemethod ? @@ -1511,11 +1509,11 @@ infoPtr = (ItclObjectInfo *)clientData; ItclShowArgs(1, "Itcl_AddObjectOptionCmd", objc, objv); if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, + Tcl_WrongNumArgs(interp, 1, objv, "objectName protection option optionName ..."); return TCL_ERROR; } - + cmd = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL, 0); if (cmd == NULL) { Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), @@ -1528,7 +1526,7 @@ "\" not found", NULL); return TCL_ERROR; } - ioPtr = Tcl_GetHashValue(hPtr); + ioPtr = (ItclObject *)Tcl_GetHashValue(hPtr); protectionStr = Tcl_GetString(objv[2]); pLevel = -1; if (strcmp(protectionStr, "public") == 0) { @@ -1597,11 +1595,11 @@ infoPtr = (ItclObjectInfo *)clientData; ItclShowArgs(1, "Itcl_AddDelegatedOptionCmd", objc, objv); if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, + Tcl_WrongNumArgs(interp, 1, objv, "className protection option optionName ..."); return TCL_ERROR; } - + cmd = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL, 0); if (cmd == NULL) { Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), @@ -1614,7 +1612,7 @@ "\" not found", NULL); return TCL_ERROR; } - ioPtr = Tcl_GetHashValue(hPtr); + ioPtr = (ItclObject *)Tcl_GetHashValue(hPtr); result = Itcl_HandleDelegateOptionCmd(interp, ioPtr, NULL, &idoPtr, objc-3, objv+3); if (result != TCL_OK) { @@ -1661,11 +1659,11 @@ infoPtr = (ItclObjectInfo *)clientData; ItclShowArgs(1, "Itcl_AddDelegatedFunctionCmd", objc, objv); if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, + Tcl_WrongNumArgs(interp, 1, objv, "className protection method/proc functionName ..."); return TCL_ERROR; } - + cmd = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL, 0); if (cmd == NULL) { Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), @@ -1678,7 +1676,7 @@ "\" not found", NULL); return TCL_ERROR; } - ioPtr = Tcl_GetHashValue(hPtr); + ioPtr = (ItclObject *)Tcl_GetHashValue(hPtr); result = Itcl_HandleDelegateMethodCmd(interp, ioPtr, NULL, &idmPtr, objc-3, objv+3); if (result != TCL_OK) { @@ -1743,7 +1741,7 @@ contextIoPtr = NULL; ItclShowArgs(1, "Itcl_AddComponentCmd", objc, objv); if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, + Tcl_WrongNumArgs(interp, 1, objv, "objectName componentName"); return TCL_ERROR; } @@ -1785,7 +1783,7 @@ " \"", Tcl_GetString(objv[2]), "\"in class variables", NULL); return TCL_ERROR; } - ivPtr = Tcl_GetHashValue(hPtr); + ivPtr = (ItclVariable *)Tcl_GetHashValue(hPtr); /* add entry to the virtual tables */ vlookup = (ItclVarLookup *)ckalloc(sizeof(ItclVarLookup)); vlookup->ivPtr = ivPtr; @@ -1819,18 +1817,13 @@ Tcl_DStringValue(&buffer), &isNew); if (isNew) { - Tcl_SetHashValue(hPtr, (ClientData)vlookup); + Tcl_SetHashValue(hPtr, vlookup); vlookup->usage++; if (!vlookup->leastQualName) { - vlookup->leastQualName = + vlookup->leastQualName = (char *) Tcl_GetHashKey(&contextIclsPtr->resolveVars, hPtr); } -#ifdef NEW_PROTO_RESOLVER - Itcl_RegisterClassVariable(contextIclsPtr->infoPtr->interp, - contextIclsPtr->nsPtr, Tcl_DStringValue(&buffer), - vlookup->classVarInfoPtr); -#endif } if (nsPtr == NULL) { @@ -1907,11 +1900,11 @@ contextIoPtr = NULL; ItclShowArgs(1, "Itcl_SetComponentCmd", objc, objv); if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, + Tcl_WrongNumArgs(interp, 1, objv, "objectName componentName value"); return TCL_ERROR; } - name = Tcl_GetStringFromObj(objv[1], (int*)NULL); + name = Tcl_GetString(objv[1]); if (Itcl_FindObject(interp, name, &contextIoPtr) != TCL_OK) { return TCL_ERROR; } @@ -1934,7 +1927,7 @@ "\" has no component \"", Tcl_GetString(objv[2]), "\"", NULL); return TCL_ERROR; } - icPtr = Tcl_GetHashValue(hPtr); + icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr), NULL, contextIoPtr, contextIclsPtr); if ((val != NULL) && (strlen(val) != 0)) { @@ -2033,8 +2026,7 @@ result = Tcl_EvalObjEx(interp, objPtr, 0); Tcl_DecrRefCount(objPtr); objPtr = Tcl_NewStringObj(iclsPtr->nsPtr->fullName, -1); - Tcl_SetResult(interp, Tcl_GetString(objPtr), TCL_VOLATILE); - Tcl_DecrRefCount(objPtr); + Tcl_SetObjResult(interp, objPtr); return result; } diff -Nru itcl4-4.1.2/generic/itcl.decls itcl4-4.2.0/generic/itcl.decls --- itcl4-4.1.2/generic/itcl.decls 2017-12-08 13:09:27.000000000 +0000 +++ itcl4-4.2.0/generic/itcl.decls 2019-10-04 16:02:02.000000000 +0000 @@ -89,6 +89,12 @@ 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 @@ -276,14 +282,14 @@ const char *arglist, const char *body) } declare 56 { - void Itcl_DeleteMemberFunc(char *cdata) + void Itcl_DeleteMemberFunc(void *cdata) } declare 57 { int Itcl_CreateMemberCode(Tcl_Interp *interp, ItclClass *iclsPtr, \ const char *arglist, const char *body, ItclMemberCode **mcodePtr) } declare 58 { - void Itcl_DeleteMemberCode(char *cdata) + void Itcl_DeleteMemberCode(void *cdata) } declare 59 { int Itcl_GetMemberCode(Tcl_Interp *interp, ItclMemberFunc *mfunc) diff -Nru itcl4-4.1.2/generic/itclDecls.h itcl4-4.2.0/generic/itclDecls.h --- itcl4-4.1.2/generic/itclDecls.h 2017-12-08 13:09:27.000000000 +0000 +++ itcl4-4.2.0/generic/itclDecls.h 2019-10-04 16:02:02.000000000 +0000 @@ -11,7 +11,7 @@ Tcl_Interp *, const char *version, int exact); #else -#define Itcl_InitStubs(interp, version, exact) Tcl_PkgRequire(interp,"itcl",version,exact) +#define Itcl_InitStubs(interp, version, exact) Tcl_PkgRequireEx(interp,"itcl",version,exact,NULL) #endif @@ -19,7 +19,7 @@ /* !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" { @@ -92,6 +92,10 @@ 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; @@ -129,6 +133,8 @@ 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; @@ -193,6 +199,10 @@ (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) */ diff -Nru itcl4-4.1.2/generic/itclEnsemble.c itcl4-4.2.0/generic/itclEnsemble.c --- itcl4-4.1.2/generic/itclEnsemble.c 2017-12-08 13:09:27.000000000 +0000 +++ itcl4-4.2.0/generic/itclEnsemble.c 2019-10-04 16:02:02.000000000 +0000 @@ -47,7 +47,7 @@ struct Ensemble* ensemble; /* ensemble containing this part */ ItclArgList *arglistPtr; /* the parsed argument list */ Tcl_ObjCmdProc *objProc; /* handling procedure for part */ - ClientData *clientData; /* the procPtr for the part */ + void *clientData; /* the procPtr for the part */ Tcl_CmdDeleteProc *deleteProc; /* procedure used to destroy client data */ int minChars; /* chars needed to uniquely identify part */ @@ -145,12 +145,11 @@ Tcl_Interp *interp) /* interpreter being initialized */ { Tcl_DString buffer; - Tcl_InterpDeleteProc *procPtr; ItclObjectInfo *infoPtr; - infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, &procPtr); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); Tcl_CreateObjCommand(interp, "::itcl::ensemble", - Itcl_EnsembleCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + Itcl_EnsembleCmd, NULL, NULL); Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, ITCL_COMMANDS_NAMESPACE, -1); @@ -223,7 +222,7 @@ if (nameArgc < 1) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid ensemble name \"", ensName, "\"", - (char*)NULL); + NULL); goto ensCreateFail; } @@ -243,7 +242,7 @@ char *pname = Tcl_Merge(nameArgc-1, nameArgv); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid ensemble name \"", pname, "\"", - (char*)NULL); + NULL); ckfree(pname); goto ensCreateFail; } @@ -330,7 +329,7 @@ char *pname = Tcl_Merge(nameArgc, nameArgv); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid ensemble name \"", pname, "\"", - (char*)NULL); + NULL); ckfree(pname); goto ensPartFail; } @@ -596,7 +595,7 @@ * * GetEnsembleUsage -- * - * + * * Returns a summary of all of the parts of an ensemble and * the meaning of their arguments. Each part is listed on * a separate line. This procedure is used internally to @@ -684,7 +683,7 @@ Tcl_DStringInit(&buffer); Itcl_InitList(&trail); for (part=ensPart; part; part=part->ensemble->parent) { - Itcl_InsertList(&trail, (ClientData)part); + Itcl_InsertList(&trail, part); } while (ensData->parent != NULL) { @@ -758,7 +757,6 @@ Tcl_Obj *objPtr; Tcl_DString buffer; Tcl_HashEntry *hPtr; - Tcl_InterpDeleteProc *procPtr; Tcl_Obj *mapDict; Tcl_Obj *toObjPtr; ItclObjectInfo *infoPtr; @@ -772,7 +770,7 @@ /* * Create the data associated with the ensemble. */ - infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, &procPtr); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); infoPtr->ensembleInfo->numEnsembles++; ensData = (Ensemble*)ckalloc(sizeof(Ensemble)); memset(ensData, 0, sizeof(Ensemble)); @@ -807,26 +805,26 @@ if (parentEnsData == NULL) { Tcl_Obj *unkObjPtr; ensData->cmdPtr = Tcl_CreateEnsemble(interp, ensName, - Tcl_GetCurrentNamespace(interp), TCL_ENSEMBLE_PREFIX); - hPtr = Tcl_CreateHashEntry(&infoPtr->ensembleInfo->ensembles, - (char *)ensData->cmdPtr, &isNew); + Tcl_GetCurrentNamespace(interp), TCL_ENSEMBLE_PREFIX); + hPtr = Tcl_CreateHashEntry(&infoPtr->ensembleInfo->ensembles, + (char *)ensData->cmdPtr, &isNew); if (!isNew) { result = TCL_ERROR; goto finish; } - Tcl_SetHashValue(hPtr, (ClientData)ensData); - unkObjPtr = Tcl_NewStringObj(ITCL_COMMANDS_NAMESPACE, -1); - Tcl_AppendToObj(unkObjPtr, "::ensembles::unknown", -1); - if (Tcl_SetEnsembleUnknownHandler(NULL, ensData->cmdPtr, - unkObjPtr) != TCL_OK) { + Tcl_SetHashValue(hPtr, ensData); + unkObjPtr = Tcl_NewStringObj(ITCL_COMMANDS_NAMESPACE, -1); + Tcl_AppendToObj(unkObjPtr, "::ensembles::unknown", -1); + if (Tcl_SetEnsembleUnknownHandler(NULL, ensData->cmdPtr, + unkObjPtr) != TCL_OK) { Tcl_DecrRefCount(unkObjPtr); result = TCL_ERROR; goto finish; - } + } - Tcl_SetResult(interp, Tcl_DStringValue(&buffer), TCL_VOLATILE); - result = TCL_OK; - goto finish; + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1)); + result = TCL_OK; + goto finish; } /* @@ -835,7 +833,7 @@ */ if (CreateEnsemblePart(interp, parentEnsData, ensName, &ensPart) != TCL_OK) { - DeleteEnsemble((ClientData)ensData); + DeleteEnsemble(ensData); result = TCL_ERROR; goto finish; } @@ -863,7 +861,7 @@ result = TCL_ERROR; goto finish; } - Tcl_SetHashValue(hPtr, (ClientData)ensData); + Tcl_SetHashValue(hPtr, ensData); unkObjPtr = Tcl_NewStringObj(ITCL_COMMANDS_NAMESPACE, -1); Tcl_AppendToObj(unkObjPtr, "::ensembles::unknown", -1); if (Tcl_SetEnsembleUnknownHandler(NULL, ensPart->cmdPtr, @@ -941,7 +939,7 @@ } if (usageInfo) { - ensPart->usage = ckalloc((unsigned)(strlen(usageInfo)+1)); + ensPart->usage = (char *)ckalloc(strlen(usageInfo)+1); strcpy(ensPart->usage, usageInfo); } ensPart->objProc = objProc; @@ -1019,7 +1017,7 @@ ckfree((char*)ensData->parts); ensData->parts = NULL; ensData->numParts = 0; - infoPtr = Tcl_GetAssocData(ensData->interp, ITCL_INTERP_DATA, NULL); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(ensData->interp, ITCL_INTERP_DATA, NULL); FOREACH_HASH_VALUE(ensData2, &infoPtr->ensembleInfo->ensembles) { if (ensData2 == ensData) { Tcl_DeleteHashEntry(hPtr); @@ -1061,7 +1059,6 @@ EnsemblePart *ensPart; Tcl_Obj *objPtr; Tcl_CmdInfo cmdInfo; - Tcl_InterpDeleteProc *procPtr; Tcl_HashEntry *hPtr; ItclObjectInfo *infoPtr; @@ -1087,15 +1084,15 @@ if (cmdPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "command \"", nameArgv[0], "\" is not an ensemble", - (char*)NULL); + NULL); return TCL_ERROR; } - infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, &procPtr); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)cmdPtr); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "command \"", nameArgv[0], "\" is not an ensemble", - (char*)NULL); + NULL); return TCL_ERROR; } ensData = (Ensemble *)Tcl_GetHashValue(hPtr); @@ -1112,7 +1109,7 @@ char *pname = Tcl_Merge(i, nameArgv); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid ensemble name \"", pname, "\"", - (char*)NULL); + NULL); ckfree(pname); return TCL_ERROR; } @@ -1121,13 +1118,13 @@ if (cmdPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "part \"", nameArgv[i], "\" is not an ensemble", - (char*)NULL); + NULL); return TCL_ERROR; } if (!Tcl_IsEnsemble(cmdPtr)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "part \"", nameArgv[i], "\" is not an ensemble", - (char*)NULL); + NULL); return TCL_ERROR; } if (Tcl_GetCommandInfoFromToken(cmdPtr, &cmdInfo) != 1) { @@ -1178,7 +1175,7 @@ if (FindEnsemblePartIndex(ensData, partName, &pos)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "part \"", partName, "\" already exists in ensemble", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -1204,7 +1201,7 @@ ensPart = (EnsemblePart*)ckalloc(sizeof(EnsemblePart)); memset(ensPart, 0, sizeof(EnsemblePart)); - ensPart->name = (char*)ckalloc((unsigned)(strlen(partName)+1)); + ensPart->name = (char*)ckalloc(strlen(partName)+1); strcpy(ensPart->name, partName); ensPart->namePtr = Tcl_NewStringObj(ensPart->name, -1); ensPart->ensemble = ensData; @@ -1233,7 +1230,7 @@ * * DeleteEnsemblePart -- * - * Deletes a single part from an ensemble. The part must have + * Deletes a single part from an ensemble. The part must have * been created previously by CreateEnsemblePart. * * If the part has a delete proc, then it is called to free the @@ -1277,11 +1274,11 @@ /* if it is a subensemble remove the command to free the data */ if (ensPart->subEnsemblePtr != NULL) { - infoPtr = Tcl_GetAssocData(ensData->interp, ITCL_INTERP_DATA, NULL); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(ensData->interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->subEnsembles, (char *)ensPart->subEnsemblePtr); if (hPtr != NULL) { - ensData2 = Tcl_GetHashValue(hPtr); + ensData2 = (Ensemble *)Tcl_GetHashValue(hPtr); Tcl_DeleteNamespace(ensData2->nsPtr); Tcl_DeleteHashEntry(hPtr); } @@ -1289,7 +1286,7 @@ hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)ensPart->ensemble->cmdPtr); if (hPtr != NULL) { - ensData2 = Tcl_GetHashValue(hPtr); + ensData2 = (Ensemble *)Tcl_GetHashValue(hPtr); Tcl_GetEnsembleMappingDict(NULL, ensData2->cmdPtr, &mapDict); if (mapDict != NULL) { Tcl_DictObjRemove(ensPart->interp, mapDict, @@ -1432,17 +1429,17 @@ } } if (nlen < ensData->parts[pos]->minChars) { - Tcl_Obj *resultPtr = Tcl_NewStringObj((char*)NULL, 0); + Tcl_Obj *resultPtr = Tcl_NewStringObj(NULL, 0); Tcl_AppendStringsToObj(resultPtr, "ambiguous option \"", partName, "\": should be one of...", - (char*)NULL); + NULL); for (i=pos; i < ensData->numParts; i++) { if (strncmp(partName, ensData->parts[i]->name, nlen) != 0) { break; } - Tcl_AppendToObj(resultPtr, "\n ", 3); + Tcl_AppendToObj(resultPtr, "\n ", 3); GetEnsemblePartUsage(interp, ensData, ensData->parts[i], resultPtr); } Tcl_SetObjResult(interp, resultPtr); @@ -1647,7 +1644,6 @@ Tcl_Command cmd; Tcl_Obj *objPtr; Tcl_HashEntry *hPtr; - Tcl_InterpDeleteProc *procPtr; ItclObjectInfo *infoPtr; ItclShowArgs(1, "Itcl_EnsembleCmd", objc, objv); @@ -1657,9 +1653,9 @@ if (objc < 2) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"", - Tcl_GetStringFromObj(objv[0], (int*)NULL), + Tcl_GetString(objv[0]), " name ?command arg arg...?\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -1700,14 +1696,14 @@ } cmd = ensPart->cmdPtr; - infoPtr = Tcl_GetAssocData(ensInfo->master, ITCL_INTERP_DATA, &procPtr); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(ensInfo->master, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)ensPart->cmdPtr); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "part \"", Tcl_GetStringFromObj(objv[1], (int*)NULL), + "part \"", Tcl_GetString(objv[1]), "\" is not an ensemble", - (char*)NULL); + NULL); return TCL_ERROR; } ensData = (Ensemble *)Tcl_GetHashValue(hPtr); @@ -1718,29 +1714,29 @@ * Find or create the access command for the ensemble, and * then get its data. */ - cmd = Tcl_FindCommand(interp, ensName, (Tcl_Namespace*)NULL, 0); + cmd = Tcl_FindCommand(interp, ensName, NULL, 0); if (cmd == NULL) { - if (CreateEnsemble(interp, (Ensemble*)NULL, ensName) + if (CreateEnsemble(interp, NULL, ensName) != TCL_OK) { return TCL_ERROR; } - cmd = Tcl_FindCommand(interp, ensName, (Tcl_Namespace*)NULL, 0); + cmd = Tcl_FindCommand(interp, ensName, NULL, 0); } if (cmd == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "command \"", Tcl_GetStringFromObj(objv[1], (int*)NULL), + "command \"", Tcl_GetString(objv[1]), "\" is not an ensemble", - (char*)NULL); + NULL); return TCL_ERROR; } - infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, &procPtr); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)cmd); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "command \"", Tcl_GetStringFromObj(objv[1], (int*)NULL), + "command \"", Tcl_GetString(objv[1]), "\" is not an ensemble", - (char*)NULL); + NULL); return TCL_ERROR; } ensData = (Ensemble *)Tcl_GetHashValue(hPtr); @@ -1749,7 +1745,7 @@ /* * At this point, we have the data for the ensemble that is * being manipulated. Plug this into the parser, and then - * interpret the rest of the arguments in the ensemble parser. + * interpret the rest of the arguments in the ensemble parser. */ status = TCL_OK; savedEnsData = ensInfo->ensData; @@ -1775,10 +1771,10 @@ if (status == TCL_ERROR) { /* no longer needed, no extra interpreter !! */ const char *errInfo = Tcl_GetVar2(ensInfo->parser, "::errorInfo", - (char*)NULL, TCL_GLOBAL_ONLY); + NULL, TCL_GLOBAL_ONLY); if (errInfo) { - Tcl_AddObjErrorInfo(interp, (const char *)errInfo, -1); + Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(errInfo, -1)); } if (objc == 3) { @@ -1846,20 +1842,20 @@ * part, delete, ensemble */ Tcl_CreateObjCommand(ensInfo->parser, "part", Itcl_EnsPartCmd, - (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL); + ensInfo, NULL); Tcl_CreateObjCommand(ensInfo->parser, "option", Itcl_EnsPartCmd, - (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL); + ensInfo, NULL); Tcl_CreateObjCommand(ensInfo->parser, "ensemble", Itcl_EnsembleCmd, - (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL); + ensInfo, NULL); /* * Install the parser data, so we'll have it the next time * we call this procedure. */ (void) Tcl_SetAssocData(interp, "itcl_ensembleParser", - DeleteEnsParser, (ClientData)ensInfo); + DeleteEnsParser, ensInfo); return ensInfo; } @@ -1947,9 +1943,9 @@ if (objc != 4) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"", - Tcl_GetStringFromObj(objv[0], (int*)NULL), + Tcl_GetString(objv[0]), " name args body\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -1959,7 +1955,7 @@ * to the namespace that contains the ensemble, but it is * accessed through the ensemble, not through a Tcl command. */ - partName = Tcl_GetStringFromObj(objv[1], (int*)NULL); + partName = Tcl_GetString(objv[1]); if (ItclCreateArgList(interp, Tcl_GetString(objv[2]), &argc, &maxArgc, &usagePtr, &arglistPtr, NULL, partName) != TCL_OK) { @@ -1986,8 +1982,11 @@ * anything goes wrong, clean up before bailing out. */ result = AddEnsemblePart(ensInfo->master, ensData, partName, usage, - Tcl_GetObjInterpProc(), (ClientData)procPtr, _Tcl_ProcDeleteProc, + (Tcl_ObjCmdProc *)Tcl_GetObjInterpProc(), procPtr, _Tcl_ProcDeleteProc, ITCL_ENSEMBLE_ENSEMBLE, &ensPart); + if (result == TCL_ERROR) { + _Tcl_ProcDeleteProc(procPtr); + } Tcl_TransferResult(ensInfo->master, result, interp); errorOut: @@ -2035,14 +2034,13 @@ cmdName = Tcl_GetString(objv[0]); - objPtr = Tcl_NewStringObj((char*)NULL, 0); + objPtr = Tcl_NewStringObj(NULL, 0); Tcl_AppendStringsToObj(objPtr, "bad option \"", cmdName, "\": should be one of...\n", - (char*)NULL); + NULL); GetEnsembleUsage(interp, ensData, objPtr); - Tcl_SetResult(interp, Tcl_GetString(objPtr), TCL_VOLATILE); - Tcl_DecrRefCount(objPtr); + Tcl_SetObjResult(interp, objPtr); return TCL_ERROR; } @@ -2060,10 +2058,10 @@ Tcl_Interp *interp, int result) { - Tcl_Namespace *nsPtr = data[0]; - EnsemblePart *ensPart = data[1]; + Tcl_Namespace *nsPtr = (Tcl_Namespace *)data[0]; + EnsemblePart *ensPart = (EnsemblePart *)data[1]; int objc = PTR2INT(data[2]); - Tcl_Obj *const*objv = data[3]; + Tcl_Obj *const *objv = (Tcl_Obj *const *)data[3]; result = Itcl_InvokeEnsembleMethod(interp, nsPtr, ensPart->namePtr, (Tcl_Proc *)ensPart->clientData, objc, objv); @@ -2076,9 +2074,9 @@ Tcl_Interp *interp, int result) { - EnsemblePart *ensPart = data[0]; + EnsemblePart *ensPart = (EnsemblePart *)data[0]; int objc = PTR2INT(data[1]); - Tcl_Obj *const*objv = data[2]; + Tcl_Obj *const*objv = (Tcl_Obj *const*)data[2]; result = (*ensPart->objProc)(ensPart->clientData, interp, objc, objv); return result; } @@ -2105,9 +2103,9 @@ if (ensPart->clientData == NULL) { return TCL_ERROR; } - Tcl_NRAddCallback(interp, CallInvokeEnsembleMethod, nsPtr, ensPart, INT2PTR(objc), (ClientData)objv); + Tcl_NRAddCallback(interp, CallInvokeEnsembleMethod, nsPtr, ensPart, INT2PTR(objc), (void *)objv); } else { - Tcl_NRAddCallback(interp, CallInvokeEnsembleMethod2, ensPart, INT2PTR(objc), (ClientData)objv, NULL); + Tcl_NRAddCallback(interp, CallInvokeEnsembleMethod2, ensPart, INT2PTR(objc), (void *)objv, NULL); } result = Itcl_NRRunCallbacks(interp, callbackPtr); return result; @@ -2129,7 +2127,6 @@ { Tcl_Command cmd; Tcl_HashEntry *hPtr; - Tcl_InterpDeleteProc *procPtr; ItclObjectInfo *infoPtr; EnsemblePart *ensPart; Ensemble *ensData; @@ -2141,7 +2138,7 @@ Tcl_GetString(objv[1]), NULL); return TCL_ERROR; } - infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, &procPtr); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)cmd); if (hPtr == NULL) { Tcl_AppendResult(interp, "EnsembleUnknownCmd, ensemble struct not ", @@ -2164,7 +2161,7 @@ if (ensPart != NULL) { Tcl_Obj *listPtr; - listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + listPtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(NULL, listPtr, objv[1]); Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj("@error", -1)); Tcl_ListObjAppendElement(NULL, listPtr, objv[2]); @@ -2211,7 +2208,7 @@ Tcl_GetString(objv[i]), "\"", NULL); return TCL_ERROR; } - ensData = Tcl_GetHashValue(hPtr); + ensData = (Ensemble *)Tcl_GetHashValue(hPtr); Itcl_RenameCommand(ensData->interp, Tcl_GetString(ensData->namePtr), ""); if (Tcl_FindNamespace(interp, ensData->nsPtr->fullName, NULL, 0) != NULL) { @@ -2233,11 +2230,5 @@ ItclFinishEnsemble( ItclObjectInfo *infoPtr) { - EnsembleParser *ensInfo; - - ensInfo = (EnsembleParser*) Tcl_GetAssocData(infoPtr->interp, - "itcl_ensembleParser", NULL); - ckfree((char *)ensInfo); - /* FIXME have to cleanup contents of infoPtr->ensembleInfo */ - ckfree((char *)infoPtr->ensembleInfo); + Tcl_DeleteAssocData(infoPtr->interp, "itcl_ensembleParser"); } diff -Nru itcl4-4.1.2/generic/itcl.h itcl4-4.2.0/generic/itcl.h --- itcl4-4.1.2/generic/itcl.h 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/generic/itcl.h 2019-10-04 16:02:02.000000000 +0000 @@ -80,12 +80,12 @@ #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" /* @@ -181,15 +181,6 @@ #include "itclDecls.h" -#ifdef ITCL_PRESERVE_DEBUG -#undef Itcl_PreserveData -#undef Itcl_ReleaseData -void ItclDbgPreserveData(ClientData cdata, int line, const char *file); -void ItclDbgReleaseData(ClientData cdata, int line, const char *file); -#define Itcl_PreserveData(addr) ItclDbgPreserveData(addr, __LINE__, __FILE__) -#define Itcl_ReleaseData(addr) ItclDbgReleaseData(addr, __LINE__, __FILE__) -#endif - #endif /* RC_INVOKED */ /* diff -Nru itcl4-4.1.2/generic/itclHelpers.c itcl4-4.2.0/generic/itclHelpers.c --- itcl4-4.1.2/generic/itclHelpers.c 2017-12-08 13:09:27.000000000 +0000 +++ itcl4-4.2.0/generic/itclHelpers.c 2019-11-03 02:24:15.000000000 +0000 @@ -1,8 +1,8 @@ /* * itclHelpers.c -- * - * This file contains the C-implemeted part of - * Itcl + * This file contains the C-implemeted part of + * Itcl * * Copyright (c) 2007 by Arnulf P. Wiedemann * @@ -128,11 +128,12 @@ commandName, "\" has argument with no name", NULL); } else { - char buf[10]; + char buf[TCL_INTEGER_SPACE]; sprintf(buf, "%d", i); Tcl_AppendResult(interp, "argument #", buf, " has no name", NULL); } + ckfree((char *) defaultArgv); result = TCL_ERROR; break; } @@ -140,14 +141,16 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "too many fields in argument specifier \"", argv[i], "\"", - (char*)NULL); + NULL); + ckfree((char *) defaultArgv); result = TCL_ERROR; break; } if (strstr(defaultArgv[0],"::")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad argument name \"", defaultArgv[0], "\"", - (char*)NULL); + NULL); + ckfree((char *) defaultArgv); result = TCL_ERROR; break; } @@ -159,7 +162,7 @@ lastArglistPtr->nextPtr = arglistPtr; Tcl_AppendToObj(*usagePtr, " ", 1); } - arglistPtr->namePtr = + arglistPtr->namePtr = Tcl_NewStringObj(defaultArgv[0], -1); Tcl_IncrRefCount(arglistPtr->namePtr); (*maxArgcPtr)++; @@ -174,7 +177,7 @@ Tcl_AppendToObj(*usagePtr, defaultArgv[0], -1); } } else { - arglistPtr->defaultValuePtr = + arglistPtr->defaultValuePtr = Tcl_NewStringObj(defaultArgv[1], -1); Tcl_IncrRefCount(arglistPtr->defaultValuePtr); Tcl_AppendToObj(*usagePtr, "?", 1); @@ -247,11 +250,7 @@ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { - int result; Tcl_Command cmd; - int cmdlinec; - Tcl_Obj **cmdlinev; - Tcl_Obj *cmdlinePtr = NULL; Tcl_CmdInfo infoPtr; /* @@ -261,44 +260,21 @@ */ cmd = Tcl_GetCommandFromObj(interp, objv[0]); - cmdlinec = objc; - cmdlinev = (Tcl_Obj **) objv; - /* - * If the command is still not found, handle it with the - * "unknown" proc. + * If the command is not found, we have no hope of a truly fast + * dispatch, so the smart thing to do is just fall back to the + * conventional tools. */ if (cmd == NULL) { - cmd = Tcl_FindCommand(interp, "unknown", - (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); - - if (cmd == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "invalid command name \"", - Tcl_GetStringFromObj(objv[0], NULL), "\"", NULL); - return TCL_ERROR; - } - - cmdlinePtr = Itcl_CreateArgs(interp, "unknown", objc, objv); - Tcl_ListObjGetElements(NULL, cmdlinePtr, &cmdlinec, &cmdlinev); + return Tcl_EvalObjv(interp, objc, objv, 0); } /* * Finally, invoke the command's Tcl_ObjCmdProc. Be careful * to pass in the proper client data. */ - Tcl_ResetResult(interp); - result = Tcl_GetCommandInfoFromToken(cmd, &infoPtr); - if (result == 1) { - result = (infoPtr.objProc)(infoPtr.objClientData, interp, - cmdlinec, cmdlinev); - } - - if (cmdlinePtr) { - Tcl_DecrRefCount(cmdlinePtr); - } - return result; + Tcl_GetCommandInfoFromToken(cmd, &infoPtr); + return (infoPtr.objProc)(infoPtr.objClientData, interp, objc, objv); } @@ -386,7 +362,7 @@ { Tcl_Obj *objPtr; char buf[2]; - + sprintf(buf, "%c", toupper(UCHAR(*str))); buf[1] = '\0'; objPtr = Tcl_NewStringObj(buf, -1); @@ -432,16 +408,16 @@ Tcl_Obj *valuePtr) { Tcl_Obj *keyPtr; + int code; if (valuePtr == NULL) { return TCL_OK; } keyPtr = Tcl_NewStringObj(keyStr, -1); - if (Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr) != TCL_OK) { - Tcl_DecrRefCount(keyPtr); - return TCL_ERROR; - } - return TCL_OK; + Tcl_IncrRefCount(keyPtr); + code = Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr); + Tcl_DecrRefCount(keyPtr); + return code; } /* @@ -1119,7 +1095,7 @@ keyPtr = iclsPtr->fullNamePtr; dictPtr = Tcl_GetVar2Ex(interp, ITCL_NAMESPACE"::internal::dicts::classVariables", - NULL, 0); + NULL, TCL_GLOBAL_ONLY); if (dictPtr == NULL) { Tcl_AppendResult(interp, "cannot get dict ", ITCL_NAMESPACE, "::internal::dicts::classVariables", NULL); @@ -1244,7 +1220,7 @@ } Tcl_SetVar2Ex(interp, ITCL_NAMESPACE"::internal::dicts::classVariables", - NULL, dictPtr, 0); + NULL, dictPtr, TCL_GLOBAL_ONLY); return TCL_OK; } @@ -1270,7 +1246,7 @@ dictPtr = Tcl_GetVar2Ex(interp, ITCL_NAMESPACE"::internal::dicts::classFunctions", - NULL, 0); + NULL, TCL_GLOBAL_ONLY); if (dictPtr == NULL) { Tcl_AppendResult(interp, "cannot get dict ", ITCL_NAMESPACE, "::internal::dicts::classFunctions", NULL); @@ -1404,7 +1380,7 @@ } Tcl_SetVar2Ex(interp, ITCL_NAMESPACE"::internal::dicts::classFunctions", - NULL, dictPtr, 0); + NULL, dictPtr, TCL_GLOBAL_ONLY); return TCL_OK; } diff -Nru itcl4-4.1.2/generic/itclInfo.c itcl4-4.2.0/generic/itclInfo.c --- itcl4-4.1.2/generic/itclInfo.c 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/generic/itclInfo.c 2019-11-03 02:24:15.000000000 +0000 @@ -201,7 +201,7 @@ ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "variable", - "?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config?", + "?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope?", Itcl_BiInfoVariableCmd, ITCL_CLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, @@ -326,7 +326,7 @@ Itcl_Stack *stackPtr = (Itcl_Stack *) Tcl_GetHashValue(hPtr); - popped = Itcl_PopStack(stackPtr); + popped = (ItclCallContext *)Itcl_PopStack(stackPtr); if (Itcl_GetStackSize(stackPtr) == 0) { Itcl_DeleteStack(stackPtr); @@ -355,7 +355,7 @@ Tcl_CallFrame *framePtr; Tcl_HashEntry *hPtr; Itcl_Stack *stackPtr; - int new; + int isNew; if (objc == 2) { /* @@ -372,8 +372,8 @@ framePtr = Itcl_GetUplevelCallFrame(interp, 0); - hPtr = Tcl_CreateHashEntry(&infoPtr->frameContext, (char *)framePtr, &new); - if (new) { + hPtr = Tcl_CreateHashEntry(&infoPtr->frameContext, (char *)framePtr, &isNew); + if (isNew) { stackPtr = (Itcl_Stack *) ckalloc(sizeof(Itcl_Stack)); Itcl_InitStack(stackPtr); Tcl_SetHashValue(hPtr, stackPtr); @@ -404,7 +404,13 @@ Tcl_Obj *const objv[]) { Tcl_CmdInfo info; - Tcl_Command token = (Tcl_Command) clientData; + ItclObjectInfo *infoPtr = (ItclObjectInfo *)clientData; + + if (!infoPtr->infoCmd) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "itcl info-subsystem is deleted", -1)); + return TCL_ERROR; + } if (objc == 1) { /* @@ -412,8 +418,6 @@ * default message of a Tcl ensemble. */ - ItclObjectInfo *infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, - ITCL_INTERP_DATA, NULL); Tcl_Obj *objPtr = Tcl_NewStringObj( "wrong # args: should be one of...\n", -1); ItclGetInfoUsage(interp, objPtr, infoPtr, NULL); @@ -423,16 +427,7 @@ /* Have a subcommand. Pass on to the ensemble */ - /* - * WARNING! WARNING! WARNING! - * We are doing NOTHING to guarantee that the command corresponding to - * token has not been deleted. If it is deleted, this will fail very - * badly. Another pass to plug up dependencies like this is in order. - * I'm not bothering now because the code is already overflowing with - * worse uncontrolled dependencies. I'll clean the windows sometime - * later when the cracks in the foundation are filled in. - */ - Tcl_GetCommandInfoFromToken(token, &info); + Tcl_GetCommandInfoFromToken(infoPtr->infoCmd, &info); return Tcl_NRCallObjProc(interp, info.objProc, info.objClientData, objc, objv); } @@ -449,11 +444,7 @@ static void InfoCmdDelete( - ClientData clientData, - Tcl_Interp *interp, - const char *oldName, - const char *newName, - int flags) + ClientData clientData) { ItclObjectInfo *infoPtr = (ItclObjectInfo *)clientData; @@ -486,16 +477,14 @@ } token = Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX); - Tcl_TraceCommand(interp, nsPtr->fullName, TCL_TRACE_DELETE, - InfoCmdDelete, (ClientData) infoPtr); infoPtr->infoCmd = token; token = Tcl_NRCreateCommand(interp, "::itcl::builtin::info", InfoWrap, - NRInfoWrap, token, NULL); + NRInfoWrap, infoPtr, InfoCmdDelete); Tcl_GetCommandInfoFromToken(token, &info); /* * Make the C implementation of the "info" ensemble available as - * a method body. This makes all [$object info] become the + * a method body. This makes all [$object info] become the * equivalent of [::itcl::builtin::Info] without any need for * tailcall to restore the right frame [87a1bc6e82]. */ @@ -511,7 +500,8 @@ Tcl_AppendToObj(cmdObjPtr, "::", 2); Tcl_AppendToObj(cmdObjPtr, InfoMethodList[i].name, -1); Tcl_CreateObjCommand(interp, Tcl_GetString(cmdObjPtr), - InfoMethodList[i].proc, infoPtr, NULL); + InfoMethodList[i].proc, infoPtr, + InfoMethodList[i].proc == Itcl_BiInfoVarsCmd ? ItclRestoreInfoVars : NULL); Tcl_DecrRefCount(cmdObjPtr); } unkObjPtr = Tcl_NewStringObj("::itcl::builtin::Info::unknown", -1); @@ -701,8 +691,8 @@ infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); if (clientData != NULL) { - oPtr = Tcl_ObjectContextObject(clientData); - contextIoPtr = Tcl_ObjectGetMetadata(oPtr, + oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)clientData); + contextIoPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, infoPtr->object_meta_type); contextIclsPtr = contextIoPtr->iclsPtr; } @@ -777,7 +767,7 @@ iclsPtr = NULL; pattern = NULL; if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { - Tcl_AppendResult(interp, "cannot get context ", (char*)NULL); + Tcl_AppendResult(interp, "cannot get context ", NULL); return TCL_ERROR; } if (objc > 2) { @@ -793,7 +783,7 @@ FOREACH_HASH_VALUE(ioptPtr, tablePtr) { name = Tcl_GetString(ioptPtr->namePtr); if ((pattern == NULL) || - Tcl_StringMatch(name, pattern)) { + Tcl_StringCaseMatch(name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(ioptPtr->namePtr), -1)); } @@ -803,7 +793,7 @@ name = Tcl_GetString(idoPtr->namePtr); if (strcmp(name, "*") != 0) { if ((pattern == NULL) || - Tcl_StringMatch(name, pattern)) { + Tcl_StringCaseMatch(name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(idoPtr->namePtr), -1)); } @@ -818,10 +808,12 @@ Tcl_GetString(idoPtr->icPtr->namePtr), NULL, ioPtr, ioPtr->iclsPtr); if ((val != NULL) && (strlen(val) != 0)) { - objPtr = Tcl_NewStringObj(val, -1); + objPtr = Tcl_NewStringObj(val, -1); Tcl_AppendToObj(objPtr, " configure", -1); + Tcl_IncrRefCount(objPtr); result = Tcl_EvalObjEx(interp, objPtr, 0); - if (result != TCL_OK) { + Tcl_DecrRefCount(objPtr); + if (result != TCL_OK) { return TCL_ERROR; } listPtr2 = Tcl_GetObjResult(interp); @@ -833,7 +825,7 @@ if (hPtr2 == NULL) { name = Tcl_GetString(objPtr); if ((pattern == NULL) || - Tcl_StringMatch(name, pattern)) { + Tcl_StringCaseMatch(name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, objPtr); } } @@ -875,7 +867,7 @@ return TCL_ERROR; } if (ioPtr == NULL) { - Tcl_AppendResult(interp, "cannot get object context ", (char*)NULL); + Tcl_AppendResult(interp, "cannot get object context ", NULL); return TCL_ERROR; } listPtr = Tcl_NewListObj(0, NULL); @@ -930,13 +922,13 @@ * Return the list of base classes. */ - listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + listPtr = Tcl_NewListObj(0, NULL); elem = Itcl_FirstListElem(&contextIclsPtr->bases); while (elem) { Tcl_Obj *objPtr; ItclClass *iclsPtr = (ItclClass*)Itcl_GetListValue(elem); objPtr = Tcl_NewStringObj(iclsPtr->nsPtr->fullName, -1); - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr); + Tcl_ListObjAppendElement(NULL, listPtr, objPtr); elem = Itcl_NextListElem(elem); } @@ -992,7 +984,7 @@ * Traverse through the derivation hierarchy and return * base class names. */ - listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + listPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { if (iclsPtr->nsPtr == NULL) { @@ -1001,7 +993,7 @@ return TCL_ERROR; } objPtr = Tcl_NewStringObj(iclsPtr->nsPtr->fullName, -1); - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr); + Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } Itcl_DeleteHierIter(&hier); @@ -1039,7 +1031,7 @@ static const char *options[] = { "-args", "-body", "-name", "-protection", "-type", - (char*)NULL + NULL }; enum BIfIdx { BIfArgsIdx, BIfBodyIdx, BIfNameIdx, BIfProtectIdx, BIfTypeIdx @@ -1107,7 +1099,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a member function in class \"", contextIclsPtr->nsPtr->fullName, "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -1129,8 +1121,8 @@ */ iflist = &iflistStorage[0]; for (i=0 ; i < objc; i++) { - result = Tcl_GetIndexFromObj(interp, objv[i], - options, "option", 0, (int*)(&iflist[i])); + result = Tcl_GetIndexFromObjStruct(interp, objv[i], + options, sizeof(char *), "option", 0, (int*)(&iflist[i])); if (result != TCL_OK) { return TCL_ERROR; } @@ -1138,7 +1130,7 @@ } if (objc > 1) { - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { @@ -1196,7 +1188,7 @@ if (objc == 1) { resultPtr = objPtr; } else { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } Tcl_SetObjResult(interp, resultPtr); @@ -1205,7 +1197,7 @@ /* * Return the list of available commands. */ - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { @@ -1234,7 +1226,7 @@ if (useIt) { objPtr = Tcl_NewStringObj( Tcl_GetString(imPtr->fullNamePtr), -1); - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } @@ -1264,6 +1256,7 @@ * to indicate success/failure. * ------------------------------------------------------------------------ */ +/*&&&1*/ /* ARGSUSED */ int Itcl_BiInfoVariableCmd( @@ -1287,14 +1280,19 @@ int i; int result; + ClientData cfClientData; + ItclObjectInfo *infoPtr; + Tcl_Object oPtr; + int doAppend; + static const char *options[] = { "-config", "-init", "-name", "-protection", "-type", - "-value", (char*)NULL + "-value", "-scope", NULL }; enum BIvIdx { BIvConfigIdx, BIvInitIdx, BIvNameIdx, BIvProtectIdx, - BIvTypeIdx, BIvValueIdx - } *ivlist, ivlistStorage[6]; + BIvTypeIdx, BIvValueIdx, BIvScopeIdx + } *ivlist, ivlistStorage[7]; static enum BIvIdx DefInfoVariable[5] = { BIvProtectIdx, @@ -1313,7 +1311,6 @@ BIvValueIdx }; - ItclShowArgs(1, "Itcl_BiInfoVariableCmd", objc, objv); resultPtr = NULL; objPtr = NULL; @@ -1335,7 +1332,7 @@ /* * Process args: - * ?varName? ?-protection? ?-type? ?-name? ?-init? ?-config? ?-value? + * ?varName? ?-protection? ?-type? ?-name? ?-init? ?-config? ?-value? ?-scope? */ objv++; /* skip over command name */ objc--; @@ -1349,12 +1346,12 @@ * Return info for a specific variable. */ if (varName) { - entry = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, varName); + entry = ItclResolveVarEntry(contextIclsPtr, varName); if (entry == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", varName, "\" isn't a variable in class \"", contextIclsPtr->nsPtr->fullName, "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -1381,8 +1378,8 @@ */ ivlist = &ivlistStorage[0]; for (i=0 ; i < objc; i++) { - result = Tcl_GetIndexFromObj(interp, objv[i], - options, "option", 0, (int*)(&ivlist[i])); + result = Tcl_GetIndexFromObjStruct(interp, objv[i], + options, sizeof(char *), "option", 0, (int*)(&ivlist[i])); if (result != TCL_OK) { return TCL_ERROR; } @@ -1390,7 +1387,7 @@ } if (objc > 1) { - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { @@ -1413,7 +1410,7 @@ if ((ivPtr->flags & ITCL_THIS_VAR) != 0) { if ((contextIoPtr != NULL) && (contextIoPtr->accessCmd != NULL)) { - objPtr = Tcl_NewStringObj((char*)NULL, 0); + objPtr = Tcl_NewStringObj(NULL, 0); Tcl_GetCommandFullName( contextIoPtr->iclsPtr->interp, contextIoPtr->accessCmd, objPtr); @@ -1460,7 +1457,7 @@ Tcl_AppendResult(interp, "cannot access object-specific info ", "without an object context", - (char*)NULL); + NULL); return TCL_ERROR; } else { val = Itcl_GetInstanceVar(interp, @@ -1473,12 +1470,84 @@ } objPtr = Tcl_NewStringObj((const char *)val, -1); break; + + case BIvScopeIdx: + entry = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, varName); + if (!entry) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "variable \"", varName, "\" not found in class \"", + Tcl_GetString(contextIclsPtr->fullNamePtr), "\"", + (char*)NULL); + return TCL_ERROR; + } + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + + if (vlookup->ivPtr->flags & ITCL_COMMON) { + objPtr = Tcl_NewStringObj("", -1); + + if (vlookup->ivPtr->protection != ITCL_PUBLIC) { + Tcl_AppendToObj(objPtr, ITCL_VARIABLES_NAMESPACE, -1); + } + Tcl_AppendToObj(objPtr, + Tcl_GetString(vlookup->ivPtr->fullNamePtr), -1); + } else { + /* + * If this is not a common variable, then we better have + * an object context. Return the name as a fully qualified name. + */ + infoPtr = contextIclsPtr->infoPtr; + cfClientData = Itcl_GetCallFrameClientData(interp); + if (cfClientData != NULL) { + oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)cfClientData); + if (oPtr != NULL) { + contextIoPtr = (ItclObject*)Tcl_ObjectGetMetadata( + oPtr, infoPtr->object_meta_type); + } + } + + if (contextIoPtr == NULL) { + if (infoPtr->currIoPtr != NULL) { + contextIoPtr = infoPtr->currIoPtr; + } + } + + if (contextIoPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't scope variable \"", varName, + "\": missing object context", + (char*)NULL); + return TCL_ERROR; + } + + doAppend = 1; + if (contextIclsPtr->flags & ITCL_ECLASS) { + if (strcmp(varName, "itcl_options") == 0) { + doAppend = 0; + } + } + + objPtr = Tcl_NewStringObj((char*)NULL, 0); + Tcl_IncrRefCount(objPtr); + Tcl_AppendToObj(objPtr, ITCL_VARIABLES_NAMESPACE, -1); + Tcl_AppendToObj(objPtr, + (Tcl_GetObjectNamespace(contextIoPtr->oPtr))->fullName, -1); + + if (doAppend) { + Tcl_AppendToObj(objPtr, + Tcl_GetString(vlookup->ivPtr->fullNamePtr), -1); + } else { + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, + Tcl_GetString(vlookup->ivPtr->namePtr), -1); + } + } + break; } if (objc == 1) { resultPtr = objPtr; } else { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } Tcl_ResetResult(interp); @@ -1490,7 +1559,7 @@ * Return the list of available variables. Report the built-in * "this" variable only once, for the most-specific class. */ - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { entry = Tcl_FirstHashEntry(&iclsPtr->variables, &place); @@ -1500,13 +1569,13 @@ if (iclsPtr == contextIclsPtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(ivPtr->fullNamePtr), -1); - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } else { objPtr = Tcl_NewStringObj( Tcl_GetString(ivPtr->fullNamePtr), -1); - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } entry = Tcl_NextHashEntry(&place); @@ -1523,7 +1592,7 @@ * ------------------------------------------------------------------------ * Itcl_BiInfoVarsCmd() * - * Returns information regarding variables + * Returns information regarding variables * * info vars ?pattern? * uses ::info vars and adds Itcl common variables!! @@ -1591,7 +1660,7 @@ if ((ivPtr->flags & ITCL_VARIABLE) != 0) { name = Tcl_GetString(ivPtr->namePtr); if ((pattern == NULL) || - Tcl_StringMatch((const char *)name, pattern)) { + Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, ivPtr->namePtr); } } @@ -1628,7 +1697,7 @@ int numElems; Itcl_InitList(&varList); - iclsPtr = Tcl_GetHashValue(hPtr); + iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); resultListPtr = Tcl_GetObjResult(interp); numElems = 0; /* FIXME !! should perhaps skip ___DO_NOT_DELETE_THIS_VARIABLE here !! */ @@ -1700,7 +1769,7 @@ if (Tcl_GetCommandFromObj(interp, objPtr)) { usage = 0; Tcl_ListObjReplace(NULL, listObj, 1, 0, objc-2, objv+2); - code = Tcl_EvalObj(interp, listObj); + code = Tcl_EvalObjEx(interp, listObj, 0); if (code == TCL_ERROR) { /* Redirection to [::info] failed, but why? */ Tcl_Obj *optDict = Tcl_GetReturnOptions(interp, code); @@ -1824,7 +1893,7 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj("", -1)); } return TCL_OK; - } + } if (contextIclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS)) { @@ -1833,7 +1902,7 @@ } if (hPtr) { - ItclDelegatedFunction *idmPtr = Tcl_GetHashValue(hPtr); + ItclDelegatedFunction *idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); Tcl_Obj *objPtr = Tcl_NewStringObj("delegated ", -1); if (idmPtr->flags & ITCL_TYPE_METHOD) { @@ -1922,7 +1991,7 @@ */ if ((mcode && mcode->argListPtr != NULL) || ((imPtr->flags & ITCL_ARG_SPEC) != 0)) { - Tcl_SetObjResult(interp, imPtr->usagePtr); + Tcl_SetObjResult(interp, mcode->usagePtr); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj("", -1)); } @@ -1936,7 +2005,7 @@ } if (hPtr) { - ItclDelegatedFunction *idmPtr = Tcl_GetHashValue(hPtr); + ItclDelegatedFunction *idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); Tcl_Obj *objPtr = Tcl_NewStringObj("delegated ", -1); if (idmPtr->flags & ITCL_TYPE_METHOD) { @@ -1983,12 +2052,12 @@ Tcl_Obj *optionNamePtr; static const char *options[] = { - "-cgetmethod", "-cgetmethodvar","-class", + "-cgetmethod", "-cgetmethodvar","-class", "-configuremethod", "-configuremethodvar", "-default", "-name", "-protection", "-resource", "-validatemethod", "-validatemethodvar", - "-value", (char*)NULL + "-value", NULL }; enum BOptIdx { BOptCgetMethodIdx, @@ -2069,17 +2138,18 @@ if (contextIoPtr == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot access object-specific info ", - "without an object context", (char*)NULL); + "without an object context", NULL); return TCL_ERROR; } optionNamePtr = Tcl_NewStringObj(optionName, -1); hPtr = Tcl_FindHashEntry(&contextIoPtr->objectOptions, (char *)optionNamePtr); + Tcl_DecrRefCount(optionNamePtr); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", optionName, "\" isn't a option in object \"", Tcl_GetString(contextIoPtr->namePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } ioptPtr = (ItclOption*)Tcl_GetHashValue(hPtr); @@ -2098,8 +2168,8 @@ */ ioptlist = &ioptlistStorage[0]; for (i=0 ; i < objc; i++) { - result = Tcl_GetIndexFromObj(interp, objv[i], - options, "option", 0, (int*)(&ioptlist[i])); + result = Tcl_GetIndexFromObjStruct(interp, objv[i], + options, sizeof(char *), "option", 0, (int*)(&ioptlist[i])); if (result != TCL_OK) { return TCL_ERROR; } @@ -2107,7 +2177,7 @@ } if (objc > 1) { - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { @@ -2211,7 +2281,7 @@ Tcl_AppendResult(interp, "cannot access object-specific info ", "without an object context", - (char*)NULL); + NULL); return TCL_ERROR; } else { val = ItclGetInstanceVar(interp, "itcl_options", @@ -2222,14 +2292,13 @@ val = ""; } objPtr = Tcl_NewStringObj((const char *)val, -1); - Tcl_IncrRefCount(objPtr); break; } if (objc == 1) { resultPtr = objPtr; } else { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } @@ -2239,15 +2308,14 @@ /* * Return the list of available options. */ - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); - Tcl_IncrRefCount(resultPtr); + resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FirstHashEntry(&iclsPtr->options, &place); while (hPtr) { ioptPtr = (ItclOption*)Tcl_GetHashValue(hPtr); objPtr = ioptPtr->namePtr; - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); hPtr = Tcl_NextHashEntry(&place); } } @@ -2287,7 +2355,7 @@ Tcl_Obj *componentNamePtr; static const char *components[] = { - "-name", "-inherit", "-value", (char*)NULL + "-name", "-inherit", "-value", NULL }; enum BCompIdx { BCompNameIdx, BCompInheritIdx, BCompValueIdx @@ -2340,7 +2408,7 @@ nsPtr->fullName, "\"", NULL); return TCL_ERROR; } - contextIclsPtr = Tcl_GetHashValue(hPtr); + contextIclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); /* * Process args: @@ -2372,12 +2440,13 @@ break; } } + Tcl_DecrRefCount(componentNamePtr); Itcl_DeleteHierIter(&hier); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", componentName, "\" isn't a component in class \"", contextIclsPtr->nsPtr->fullName, "\"", - (char*)NULL); + NULL); return TCL_ERROR; } icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); @@ -2396,8 +2465,8 @@ */ icomplist = &icomplistStorage[0]; for (i=0 ; i < objc; i++) { - result = Tcl_GetIndexFromObj(interp, objv[i], - components, "component", 0, (int*)(&icomplist[i])); + result = Tcl_GetIndexFromObjStruct(interp, objv[i], + components, sizeof(char *), "component", 0, (int*)(&icomplist[i])); if (result != TCL_OK) { return TCL_ERROR; } @@ -2405,7 +2474,7 @@ } if (objc > 1) { - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { @@ -2430,7 +2499,7 @@ Tcl_AppendResult(interp, "cannot access object-specific info ", "without an object context", - (char*)NULL); + NULL); return TCL_ERROR; } else { val = ItclGetInstanceVar(interp, @@ -2441,14 +2510,13 @@ val = ""; } objPtr = Tcl_NewStringObj((const char *)val, -1); - Tcl_IncrRefCount(objPtr); break; } if (objc == 1) { resultPtr = objPtr; } else { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } @@ -2458,8 +2526,7 @@ /* * Return the list of available components. */ - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); - Tcl_IncrRefCount(resultPtr); + resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FirstHashEntry(&iclsPtr->components, &place); @@ -2467,7 +2534,7 @@ icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); objPtr = Tcl_NewStringObj( Tcl_GetString(icPtr->ivPtr->fullNamePtr), -1); - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); hPtr = Tcl_NextHashEntry(&place); } } @@ -2511,7 +2578,7 @@ if (objc != 1) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"info widget\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -2529,8 +2596,8 @@ infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); if (clientData != NULL) { - oPtr = Tcl_ObjectContextObject(clientData); - contextIoPtr = Tcl_ObjectGetMetadata(oPtr, + oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)clientData); + contextIoPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, infoPtr->object_meta_type); contextIclsPtr = contextIoPtr->iclsPtr; } @@ -2552,15 +2619,11 @@ } else { assert(contextIclsPtr != NULL); assert(contextIclsPtr->nsPtr != NULL); -#ifdef NEW_PROTO_RESOLVER - contextNs = contextIclsPtr->nsPtr; -#else if (contextIclsPtr->infoPtr->useOldResolvers) { contextNs = contextIclsPtr->nsPtr; } else { contextNs = contextIclsPtr->nsPtr; } -#endif } name = contextNs->fullName; @@ -2581,7 +2644,7 @@ * Returns information regarding extendedclasses. * Handles the following syntax: * - * info extendedclass ?className? + * info extendedclass ?className? * * If the ?className? is not specified, then a list of all known * data members is returned. Otherwise, the information for a @@ -2599,7 +2662,7 @@ { #ifdef NOTYET static const char *components[] = { - "-name", "-inherit", "-value", (char*)NULL + "-name", "-inherit", "-value", NULL }; enum BCompIdx { BCompNameIdx, BCompInheritIdx, BCompValueIdx @@ -2664,7 +2727,7 @@ * Returns information regarding extendedclasses. * Handles the following syntax: * - * info extendedclass ?className? + * info extendedclass ?className? * * If the ?className? is not specified, then a list of all known * data members is returned. Otherwise, the information for a @@ -2682,7 +2745,7 @@ { #ifdef NOTYET static const char *components[] = { - "-name", "-inherit", "-value", (char*)NULL + "-name", "-inherit", "-value", NULL }; enum BCompIdx { BCompNameIdx, BCompInheritIdx, BCompValueIdx @@ -2771,7 +2834,7 @@ if (objc != 1) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"info type\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -2789,14 +2852,14 @@ infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); if (clientData != NULL) { - oPtr = Tcl_ObjectContextObject(clientData); - contextIoPtr = Tcl_ObjectGetMetadata(oPtr, + oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)clientData); + contextIoPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, infoPtr->object_meta_type); contextIclsPtr = contextIoPtr->iclsPtr; } if ((contextIoPtr == NULL) || (contextIclsPtr == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\nget info like this instead: " + "\nget info like this instead: " "\n namespace eval className { info type ...}", -1)); return TCL_ERROR; } @@ -2812,15 +2875,11 @@ } else { assert(contextIclsPtr != NULL); assert(contextIclsPtr->nsPtr != NULL); -#ifdef NEW_PROTO_RESOLVER - contextNs = contextIclsPtr->nsPtr; -#else if (contextIclsPtr->infoPtr->useOldResolvers) { contextNs = contextIclsPtr->nsPtr; } else { contextNs = contextIclsPtr->nsPtr; } -#endif } name = contextNs->fullName; @@ -2860,7 +2919,7 @@ if (objc != 1) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"info hulltype\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -2878,8 +2937,8 @@ infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); if (clientData != NULL) { - oPtr = Tcl_ObjectContextObject(clientData); - contextIoPtr = Tcl_ObjectGetMetadata(oPtr, + oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)clientData); + contextIoPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, infoPtr->object_meta_type); contextIclsPtr = contextIoPtr->iclsPtr; } @@ -2962,7 +3021,7 @@ argListPtr->defaultValuePtr, TCL_LEAVE_ERR_MSG)) { return TCL_ERROR; } - Tcl_SetResult(interp, "1", NULL); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); return TCL_OK; } else { Tcl_AppendResult(interp, "method \"", methodName, @@ -3032,7 +3091,7 @@ static const char *options[] = { "-args", "-body", "-name", "-protection", "-type", - (char*)NULL + NULL }; enum BIfIdx { BIfArgsIdx, BIfBodyIdx, BIfNameIdx, BIfProtectIdx, BIfTypeIdx @@ -3090,7 +3149,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a method in class \"", contextIclsPtr->nsPtr->fullName, "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -3101,7 +3160,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a method in class \"", contextIclsPtr->nsPtr->fullName, "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -3119,8 +3178,8 @@ */ iflist = &iflistStorage[0]; for (i=0 ; i < objc; i++) { - result = Tcl_GetIndexFromObj(interp, objv[i], - options, "option", 0, (int*)(&iflist[i])); + result = Tcl_GetIndexFromObjStruct(interp, objv[i], + options, sizeof(char *), "option", 0, (int*)(&iflist[i])); if (result != TCL_OK) { return TCL_ERROR; } @@ -3128,7 +3187,7 @@ } if (objc > 1) { - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { @@ -3185,7 +3244,7 @@ if (objc == 1) { resultPtr = objPtr; } else { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } Tcl_SetObjResult(interp, resultPtr); @@ -3194,7 +3253,7 @@ /* * Return the list of available commands. */ - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { @@ -3209,7 +3268,7 @@ if (useIt) { objPtr = Tcl_NewStringObj( Tcl_GetString(imPtr->fullNamePtr), -1); - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } @@ -3255,7 +3314,7 @@ iclsPtr = NULL; pattern = NULL; if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { - Tcl_AppendResult(interp, "cannot get context ", (char*)NULL); + Tcl_AppendResult(interp, "cannot get context ", NULL); return TCL_ERROR; } if (ioPtr != NULL) { @@ -3266,12 +3325,12 @@ } listPtr = Tcl_NewListObj(0, NULL); name = "destroy"; - if ((pattern == NULL) || Tcl_StringMatch((const char *)name, pattern)) { + if ((pattern == NULL) || Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(name, -1)); } name = "info"; - if ((pattern == NULL) || Tcl_StringMatch((const char *)name, pattern)) { + if ((pattern == NULL) || Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(name, -1)); } @@ -3292,7 +3351,7 @@ !(imPtr->flags & ITCL_COMMON) && !(imPtr->codePtr->flags & ITCL_BUILTIN)) { if ((pattern == NULL) || - Tcl_StringMatch((const char *)name, pattern)) { + Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(imPtr->namePtr), -1)); } @@ -3311,7 +3370,7 @@ } if (idmPtr->flags & ITCL_METHOD) { if ((pattern == NULL) || - Tcl_StringMatch((const char *)name, pattern)) { + Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(idmPtr->namePtr), -1)); } @@ -3362,7 +3421,7 @@ iclsPtr = NULL; pattern = NULL; if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { - Tcl_AppendResult(interp, "cannot get context ", (char*)NULL); + Tcl_AppendResult(interp, "cannot get context ", NULL); return TCL_ERROR; } if (ioPtr != NULL) { @@ -3385,7 +3444,7 @@ FOREACH_HASH_VALUE(ioptPtr, tablePtr) { name = Tcl_GetString(ioptPtr->namePtr); if ((pattern == NULL) || - Tcl_StringMatch(name, pattern)) { + Tcl_StringCaseMatch(name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(ioptPtr->namePtr), -1)); } @@ -3399,7 +3458,7 @@ name = Tcl_GetString(idoPtr->namePtr); if (strcmp(name, "*") != 0) { if ((pattern == NULL) || - Tcl_StringMatch(name, pattern)) { + Tcl_StringCaseMatch(name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(idoPtr->namePtr), -1)); } @@ -3429,7 +3488,7 @@ if (hPtr2 == NULL) { name = Tcl_GetString(objPtr); if ((pattern == NULL) || - Tcl_StringMatch(name, pattern)) { + Tcl_StringCaseMatch(name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, objPtr); } } @@ -3484,7 +3543,7 @@ if (iclsPtr->flags & ITCL_TYPE) { name = Tcl_GetString(iclsPtr->namePtr); if ((pattern == NULL) || - Tcl_StringMatch(name, pattern)) { + Tcl_StringCaseMatch(name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(iclsPtr->namePtr), -1)); } @@ -3527,14 +3586,14 @@ iclsPtr = NULL; pattern = NULL; if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { - Tcl_AppendResult(interp, "cannot get context ", (char*)NULL); + Tcl_AppendResult(interp, "cannot get context ", NULL); return TCL_ERROR; } if (ioPtr != NULL) { iclsPtr = ioPtr->iclsPtr; } if (iclsPtr == NULL) { - Tcl_AppendResult(interp, "INTERNAL ERROR in Itcl_BiInfoComponentsCmd", + Tcl_AppendResult(interp, "INTERNAL ERROR in Itcl_BiInfoComponentsCmd", " iclsPtr == NULL", NULL); return TCL_ERROR; } @@ -3553,7 +3612,7 @@ FOREACH_HASH_VALUE(icPtr, &iclsPtr2->components) { name = Tcl_GetString(icPtr->namePtr); if ((pattern == NULL) || - Tcl_StringMatch(name, pattern)) { + Tcl_StringCaseMatch(name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(icPtr->namePtr), -1)); } @@ -3601,7 +3660,7 @@ static const char *options[] = { "-args", "-body", "-name", "-protection", "-type", - (char*)NULL + NULL }; enum BIfIdx { BIfArgsIdx, BIfBodyIdx, BIfNameIdx, BIfProtectIdx, BIfTypeIdx @@ -3660,7 +3719,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a typemethod in class \"", contextIclsPtr->nsPtr->fullName, "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -3671,7 +3730,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a typemethod in class \"", contextIclsPtr->nsPtr->fullName, "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -3689,8 +3748,8 @@ */ iflist = &iflistStorage[0]; for (i=0 ; i < objc; i++) { - result = Tcl_GetIndexFromObj(interp, objv[i], - options, "option", 0, (int*)(&iflist[i])); + result = Tcl_GetIndexFromObjStruct(interp, objv[i], + options, sizeof(char *), "option", 0, (int*)(&iflist[i])); if (result != TCL_OK) { return TCL_ERROR; } @@ -3698,7 +3757,7 @@ } if (objc > 1) { - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { @@ -3755,7 +3814,7 @@ if (objc == 1) { resultPtr = objPtr; } else { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } Tcl_SetObjResult(interp, resultPtr); @@ -3764,7 +3823,7 @@ /* * Return the list of available commands. */ - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { @@ -3779,7 +3838,7 @@ if (useIt) { objPtr = Tcl_NewStringObj( Tcl_GetString(imPtr->fullNamePtr), -1); - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } @@ -3825,7 +3884,7 @@ iclsPtr = NULL; pattern = NULL; if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { - Tcl_AppendResult(interp, "cannot get context ", (char*)NULL); + Tcl_AppendResult(interp, "cannot get context ", NULL); return TCL_ERROR; } if (ioPtr != NULL) { @@ -3836,17 +3895,17 @@ } listPtr = Tcl_NewListObj(0, NULL); name = "create"; - if ((pattern == NULL) || Tcl_StringMatch((const char *)name, pattern)) { + if ((pattern == NULL) || Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(name, -1)); } name = "destroy"; - if ((pattern == NULL) || Tcl_StringMatch((const char *)name, pattern)) { + if ((pattern == NULL) || Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(name, -1)); } name = "info"; - if ((pattern == NULL) || Tcl_StringMatch((const char *)name, pattern)) { + if ((pattern == NULL) || Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(name, -1)); } @@ -3866,7 +3925,7 @@ } if (imPtr->flags & ITCL_TYPE_METHOD) { if ((pattern == NULL) || - Tcl_StringMatch((const char *)name, pattern)) { + Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(imPtr->namePtr), -1)); } @@ -3888,7 +3947,7 @@ } if (idmPtr->flags & ITCL_TYPE_METHOD) { if ((pattern == NULL) || - Tcl_StringMatch((const char *)name, pattern)) { + Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(idmPtr->namePtr), -1)); } @@ -3933,7 +3992,7 @@ iclsPtr = NULL; pattern = NULL; if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { - Tcl_AppendResult(interp, "cannot get context ", (char*)NULL); + Tcl_AppendResult(interp, "cannot get context ", NULL); return TCL_ERROR; } if (ioPtr != NULL) { @@ -3945,7 +4004,7 @@ listPtr = Tcl_NewListObj(0, NULL); FOREACH_HASH_VALUE(ivPtr, &iclsPtr->variables) { if ((pattern == NULL) || - Tcl_StringMatch(Tcl_GetString(ivPtr->namePtr), pattern)) { + Tcl_StringCaseMatch(Tcl_GetString(ivPtr->namePtr), pattern, 0)) { if (ivPtr->flags & ITCL_TYPE_VARIABLE) { Tcl_ListObjAppendElement(interp, listPtr, ivPtr->fullNamePtr); } @@ -3991,7 +4050,7 @@ static const char *options[] = { "-init", "-name", "-protection", "-type", - "-value", (char*)NULL + "-value", NULL }; enum BIvIdx { BIvInitIdx, @@ -4044,12 +4103,12 @@ * Return info for a specific variable. */ if (varName) { - hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, varName); + hPtr = ItclResolveVarEntry(contextIclsPtr, varName); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", varName, "\" isn't a typevariable in class \"", contextIclsPtr->nsPtr->fullName, "\"", - (char*)NULL); + NULL); return TCL_ERROR; } vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); @@ -4058,7 +4117,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", varName, "\" isn't a typevariable in class \"", contextIclsPtr->nsPtr->fullName, "\"", - (char*)NULL); + NULL); return TCL_ERROR; } /* @@ -4075,8 +4134,8 @@ */ ivlist = &ivlistStorage[0]; for (i=0 ; i < objc; i++) { - result = Tcl_GetIndexFromObj(interp, objv[i], - options, "option", 0, (int*)(&ivlist[i])); + result = Tcl_GetIndexFromObjStruct(interp, objv[i], + options, sizeof(char *), "option", 0, (int*)(&ivlist[i])); if (result != TCL_OK) { return TCL_ERROR; } @@ -4084,7 +4143,7 @@ } if (objc > 1) { - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { @@ -4097,7 +4156,7 @@ if ((ivPtr->flags & ITCL_THIS_VAR) != 0) { if ((contextIoPtr != NULL) && (contextIoPtr->accessCmd != NULL)) { - objPtr = Tcl_NewStringObj((char*)NULL, 0); + objPtr = Tcl_NewStringObj(NULL, 0); Tcl_GetCommandFullName( contextIoPtr->iclsPtr->interp, contextIoPtr->accessCmd, objPtr); @@ -4144,7 +4203,7 @@ Tcl_AppendResult(interp, "cannot access object-specific info ", "without an object context", - (char*)NULL); + NULL); return TCL_ERROR; } else { val = Itcl_GetInstanceVar(interp, @@ -4162,7 +4221,7 @@ if (objc == 1) { resultPtr = objPtr; } else { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } Tcl_ResetResult(interp); @@ -4174,7 +4233,7 @@ * Return the list of available variables. Report the built-in * "this" variable only once, for the most-specific class. */ - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FirstHashEntry(&iclsPtr->variables, &place); @@ -4185,13 +4244,13 @@ if (iclsPtr == contextIclsPtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(ivPtr->fullNamePtr), -1); - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } else { objPtr = Tcl_NewStringObj( Tcl_GetString(ivPtr->fullNamePtr), -1); - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } @@ -4259,7 +4318,7 @@ if (objc != 1) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"info widgetadaptor\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -4277,14 +4336,14 @@ infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); if (clientData != NULL) { - oPtr = Tcl_ObjectContextObject(clientData); - contextIoPtr = Tcl_ObjectGetMetadata(oPtr, + oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)clientData); + contextIoPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, infoPtr->object_meta_type); contextIclsPtr = contextIoPtr->iclsPtr; } if ((contextIoPtr == NULL) || (contextIclsPtr == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\nget info like this instead: " + "\nget info like this instead: " "\n namespace eval className { info widgetadaptor ... }", -1)); return TCL_ERROR; } @@ -4300,15 +4359,11 @@ } else { assert(contextIclsPtr != NULL); assert(contextIclsPtr->nsPtr != NULL); -#ifdef NEW_PROTO_RESOLVER - contextNs = contextIclsPtr->nsPtr; -#else if (contextIclsPtr->infoPtr->useOldResolvers) { contextNs = contextIclsPtr->nsPtr; } else { contextNs = contextIclsPtr->nsPtr; } -#endif } name = contextNs->fullName; @@ -4357,7 +4412,7 @@ iclsPtr = NULL; pattern = NULL; if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { - Tcl_AppendResult(interp, "cannot get context ", (char*)NULL); + Tcl_AppendResult(interp, "cannot get context ", NULL); return TCL_ERROR; } if (ioPtr != NULL) { @@ -4379,7 +4434,7 @@ Tcl_GetCommandFullName(interp, ioPtr->accessCmd, objPtr); } if ((pattern == NULL) || - Tcl_StringMatch(Tcl_GetString(objPtr), pattern)) { + Tcl_StringCaseMatch(Tcl_GetString(objPtr), pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, objPtr); } else { Tcl_DecrRefCount(objPtr); @@ -4442,7 +4497,7 @@ (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS)) { name = Tcl_GetString(idoPtr->namePtr); if ((pattern == NULL) || - Tcl_StringMatch(name, pattern)) { + Tcl_StringCaseMatch(name, pattern, 0)) { objPtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(interp, objPtr, idoPtr->namePtr); @@ -4451,7 +4506,6 @@ idoPtr->icPtr->namePtr); } else { objPtr2 = Tcl_NewStringObj("", -1); - Tcl_IncrRefCount(objPtr2); Tcl_ListObjAppendElement(interp, objPtr, objPtr2); } Tcl_ListObjAppendElement(interp, listPtr, objPtr); @@ -4514,7 +4568,7 @@ (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS)) { name = Tcl_GetString(idmPtr->namePtr); if ((pattern == NULL) || - Tcl_StringMatch(name, pattern)) { + Tcl_StringCaseMatch(name, pattern, 0)) { if ((idmPtr->flags & ITCL_TYPE_METHOD) == 0) { objPtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(interp, objPtr, @@ -4524,7 +4578,6 @@ idmPtr->icPtr->namePtr); } else { objPtr2 = Tcl_NewStringObj("", -1); - Tcl_IncrRefCount(objPtr2); Tcl_ListObjAppendElement(interp, objPtr, objPtr2); } Tcl_ListObjAppendElement(interp, listPtr, objPtr); @@ -4588,7 +4641,7 @@ (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS)) { name = Tcl_GetString(idmPtr->namePtr); if ((pattern == NULL) || - Tcl_StringMatch(name, pattern)) { + Tcl_StringCaseMatch(name, pattern, 0)) { if (idmPtr->flags & ITCL_TYPE_METHOD) { objPtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(interp, objPtr, @@ -4598,7 +4651,6 @@ idmPtr->icPtr->namePtr); } else { objPtr2 = Tcl_NewStringObj("", -1); - Tcl_IncrRefCount(objPtr2); Tcl_ListObjAppendElement(interp, objPtr, objPtr2); } Tcl_ListObjAppendElement(interp, listPtr, objPtr); @@ -4678,7 +4730,7 @@ static const char *options[] = { "-as", "-class", "-component", "-exceptions", - "-name", "-resource", (char*)NULL + "-name", "-resource", NULL }; enum BOptIdx { BOptAsIdx, BOptClassIdx, BOptComponentIdx, BOptExceptionsIdx, @@ -4720,7 +4772,7 @@ nsPtr->fullName, "\"", NULL); return TCL_ERROR; } - contextIclsPtr = Tcl_GetHashValue(hPtr); + contextIclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); /* * Process args: @@ -4743,17 +4795,18 @@ if (contextIoPtr == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot access object-specific info ", - "without an object context", (char*)NULL); + "without an object context", NULL); return TCL_ERROR; } optionNamePtr = Tcl_NewStringObj(optionName, -1); hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions, (char *)optionNamePtr); + Tcl_DecrRefCount(optionNamePtr); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", optionName, "\" isn't an option in object \"", Tcl_GetString(contextIoPtr->namePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } idoptPtr = (ItclDelegatedOption*)Tcl_GetHashValue(hPtr); @@ -4772,8 +4825,8 @@ */ ioptlist = &ioptlistStorage[0]; for (i=0 ; i < objc; i++) { - result = Tcl_GetIndexFromObj(interp, objv[i], - options, "option", 0, (int*)(&ioptlist[i])); + result = Tcl_GetIndexFromObjStruct(interp, objv[i], + options, sizeof(char *), "option", 0, (int*)(&ioptlist[i])); if (result != TCL_OK) { return TCL_ERROR; } @@ -4781,7 +4834,7 @@ } if (objc > 1) { - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { @@ -4798,15 +4851,10 @@ case BOptExceptionsIdx: { Tcl_Obj *entryObj; - int hadEntries; - hadEntries = 0; objPtr = Tcl_NewListObj(0, NULL); FOREACH_HASH_VALUE(entryObj, &idoptPtr->exceptions) { Tcl_ListObjAppendElement(interp, objPtr, entryObj); } - if (!hadEntries) { - objPtr = Tcl_NewStringObj("", -1); - } } break; case BOptResourceIdx: @@ -4846,7 +4894,7 @@ if (objc == 1) { resultPtr = objPtr; } else { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } @@ -4856,15 +4904,14 @@ /* * Return the list of available options. */ - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); - Tcl_IncrRefCount(resultPtr); + resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FirstHashEntry(&iclsPtr->delegatedOptions, &place); while (hPtr) { idoptPtr = (ItclDelegatedOption*)Tcl_GetHashValue(hPtr); objPtr = idoptPtr->namePtr; - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); hPtr = Tcl_NextHashEntry(&place); } } @@ -4915,7 +4962,7 @@ static const char *options[] = { "-as", "-component", "-exceptions", - "-name", "-using", (char*)NULL + "-name", "-using", NULL }; enum BOptIdx { BOptAsIdx, @@ -4978,11 +5025,12 @@ hPtr = Tcl_FindHashEntry(&contextIclsPtr->delegatedFunctions, (char *)cmdNamePtr); } + Tcl_DecrRefCount(cmdNamePtr); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a delegated method in object \"", Tcl_GetString(contextIoPtr->namePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } idmPtr = (ItclDelegatedFunction*)Tcl_GetHashValue(hPtr); @@ -4990,7 +5038,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a delegated method in object \"", Tcl_GetString(contextIoPtr->namePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } /* @@ -5007,8 +5055,8 @@ */ ioptlist = &ioptlistStorage[0]; for (i=0 ; i < objc; i++) { - result = Tcl_GetIndexFromObj(interp, objv[i], - options, "option", 0, (int*)(&ioptlist[i])); + result = Tcl_GetIndexFromObjStruct(interp, objv[i], + options, sizeof(char *), "option", 0, (int*)(&ioptlist[i])); if (result != TCL_OK) { return TCL_ERROR; } @@ -5016,7 +5064,7 @@ } if (objc > 1) { - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { @@ -5033,15 +5081,10 @@ case BOptExceptionsIdx: { Tcl_Obj *entryObj; - int hadEntries; - hadEntries = 0; objPtr = Tcl_NewListObj(0, NULL); FOREACH_HASH_VALUE(entryObj, &idmPtr->exceptions) { Tcl_ListObjAppendElement(interp, objPtr, entryObj); } - if (!hadEntries) { - objPtr = Tcl_NewStringObj("", -1); - } } break; case BOptUsingIdx: @@ -5072,7 +5115,7 @@ if (objc == 1) { resultPtr = objPtr; } else { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } @@ -5082,8 +5125,7 @@ /* * Return the list of available options. */ - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); - Tcl_IncrRefCount(resultPtr); + resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FirstHashEntry(&iclsPtr->delegatedFunctions, &place); @@ -5091,7 +5133,7 @@ idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); if (idmPtr->flags & ITCL_METHOD) { objPtr = idmPtr->namePtr; - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } hPtr = Tcl_NextHashEntry(&place); @@ -5145,7 +5187,7 @@ static const char *options[] = { "-as", "-component", "-exceptions", - "-name", "-using", (char*)NULL + "-name", "-using", NULL }; enum BOptIdx { BOptAsIdx, @@ -5208,12 +5250,13 @@ hPtr = Tcl_FindHashEntry(&contextIclsPtr->delegatedFunctions, (char *)cmdNamePtr); } + Tcl_DecrRefCount(cmdNamePtr); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a delegated typemethod in ", contextIoPtr ? "object \"" : "class \"", contextIoPtr ? Tcl_GetString(contextIoPtr->namePtr) - : Tcl_GetString(contextIclsPtr->namePtr), "\"", (char*)NULL); + : Tcl_GetString(contextIclsPtr->namePtr), "\"", NULL); return TCL_ERROR; } idmPtr = (ItclDelegatedFunction*)Tcl_GetHashValue(hPtr); @@ -5222,7 +5265,7 @@ "\"", cmdName, "\" isn't a delegated typemethod in ", contextIoPtr ? "object \"" : "class \"", contextIoPtr ? Tcl_GetString(contextIoPtr->namePtr) - : Tcl_GetString(contextIclsPtr->namePtr), "\"", (char*)NULL); + : Tcl_GetString(contextIclsPtr->namePtr), "\"", NULL); return TCL_ERROR; } /* @@ -5239,8 +5282,8 @@ */ ioptlist = &ioptlistStorage[0]; for (i=0 ; i < objc; i++) { - result = Tcl_GetIndexFromObj(interp, objv[i], - options, "option", 0, (int*)(&ioptlist[i])); + result = Tcl_GetIndexFromObjStruct(interp, objv[i], + options, sizeof(char *), "option", 0, (int*)(&ioptlist[i])); if (result != TCL_OK) { return TCL_ERROR; } @@ -5248,7 +5291,7 @@ } if (objc > 1) { - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { @@ -5265,15 +5308,10 @@ case BOptExceptionsIdx: { Tcl_Obj *entryObj; - int hadEntries; - hadEntries = 0; objPtr = Tcl_NewListObj(0, NULL); FOREACH_HASH_VALUE(entryObj, &idmPtr->exceptions) { Tcl_ListObjAppendElement(interp, objPtr, entryObj); } - if (!hadEntries) { - objPtr = Tcl_NewStringObj("", -1); - } } break; case BOptUsingIdx: @@ -5304,7 +5342,7 @@ if (objc == 1) { resultPtr = objPtr; } else { - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } @@ -5314,8 +5352,7 @@ /* * Return the list of available options. */ - resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); - Tcl_IncrRefCount(resultPtr); + resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FirstHashEntry(&iclsPtr->delegatedFunctions, &place); @@ -5323,7 +5360,7 @@ idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); if (idmPtr->flags & ITCL_TYPE_METHOD) { objPtr = idmPtr->namePtr; - Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } hPtr = Tcl_NextHashEntry(&place); diff -Nru itcl4-4.1.2/generic/itclIntDecls.h itcl4-4.2.0/generic/itclIntDecls.h --- itcl4-4.1.2/generic/itclIntDecls.h 2017-12-08 13:09:27.000000000 +0000 +++ itcl4-4.2.0/generic/itclIntDecls.h 2019-10-04 16:02:02.000000000 +0000 @@ -8,7 +8,7 @@ /* !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" { @@ -180,13 +180,13 @@ ItclMemberFunc *mfunc, const char *arglist, const char *body); /* 56 */ -ITCLAPI void Itcl_DeleteMemberFunc(char *cdata); +ITCLAPI void Itcl_DeleteMemberFunc(void *cdata); /* 57 */ ITCLAPI int Itcl_CreateMemberCode(Tcl_Interp *interp, ItclClass *iclsPtr, const char *arglist, const char *body, ItclMemberCode **mcodePtr); /* 58 */ -ITCLAPI void Itcl_DeleteMemberCode(char *cdata); +ITCLAPI void Itcl_DeleteMemberCode(void *cdata); /* 59 */ ITCLAPI int Itcl_GetMemberCode(Tcl_Interp *interp, ItclMemberFunc *mfunc); @@ -584,9 +584,9 @@ int (*itcl_CreateProc) (Tcl_Interp *interp, ItclClass *iclsPtr, Tcl_Obj *namePtr, const char *arglist, const char *body); /* 53 */ int (*itcl_CreateMemberFunc) (Tcl_Interp *interp, ItclClass *iclsPtr, Tcl_Obj *name, const char *arglist, const char *body, ItclMemberFunc **mfuncPtr); /* 54 */ int (*itcl_ChangeMemberFunc) (Tcl_Interp *interp, ItclMemberFunc *mfunc, const char *arglist, const char *body); /* 55 */ - void (*itcl_DeleteMemberFunc) (char *cdata); /* 56 */ + void (*itcl_DeleteMemberFunc) (void *cdata); /* 56 */ int (*itcl_CreateMemberCode) (Tcl_Interp *interp, ItclClass *iclsPtr, const char *arglist, const char *body, ItclMemberCode **mcodePtr); /* 57 */ - void (*itcl_DeleteMemberCode) (char *cdata); /* 58 */ + void (*itcl_DeleteMemberCode) (void *cdata); /* 58 */ int (*itcl_GetMemberCode) (Tcl_Interp *interp, ItclMemberFunc *mfunc); /* 59 */ void (*reserved60)(void); int (*itcl_EvalMemberCode) (Tcl_Interp *interp, ItclMemberFunc *mfunc, ItclObject *contextObj, int objc, Tcl_Obj *const objv[]); /* 61 */ diff -Nru itcl4-4.1.2/generic/itclInt.h itcl4-4.2.0/generic/itclInt.h --- itcl4-4.1.2/generic/itclInt.h 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/generic/itclInt.h 2019-11-05 14:34:35.000000000 +0000 @@ -48,18 +48,30 @@ #endif /* + * MSVC 8.0 started to mark many standard C library functions depreciated + * including the *printf family and others. Tell it to shut up. + * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0) + */ +#if defined(_MSC_VER) +# pragma warning(disable:4244) +# if _MSC_VER >= 1400 +# pragma warning(disable:4267) +# pragma warning(disable:4996) +# endif +#endif + +/* * Since the Tcl/Tk distribution doesn't perform any asserts, * dynamic loading can fail to find the __assert function. * As a workaround, we'll include our own. */ #undef assert -#define DEBUG 1 -#ifndef DEBUG +#if defined(NDEBUG) && !defined(DEBUG) #define assert(EX) ((void)0) -#else +#else /* !NDEBUG || DEBUG */ #define assert(EX) (void)((EX) || (Itcl_Assert(STRINGIFY(EX), __FILE__, __LINE__), 0)) -#endif /* DEBUG */ +#endif #define ITCL_INTERP_DATA "itcl_data" #define ITCL_TK_VERSION "8.6" @@ -75,11 +87,11 @@ Tcl_HashEntry *hPtr;Tcl_HashSearch search #define FOREACH_HASH(key,val,tablePtr) \ for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \ - ((key)=(void *)Tcl_GetHashKey((tablePtr),hPtr),\ - (val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search)) + (*(void **)&(key)=Tcl_GetHashKey((tablePtr),hPtr),\ + *(void **)&(val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search)) #define FOREACH_HASH_VALUE(val,tablePtr) \ for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \ - ((val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search)) + (*(void **)&(val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search)) /* * What sort of size of things we like to allocate. @@ -87,31 +99,10 @@ #define ALLOC_CHUNK 8 -#define ITCL_VARIABLES_NAMESPACE "::itcl::internal::variables" -#define ITCL_COMMANDS_NAMESPACE "::itcl::internal::commands" - -#ifdef ITCL_PRESERVE_DEBUG -#define ITCL_PRESERVE_BUCKET_SIZE 50 -#define ITCL_PRESERVE_INCR 1 -#define ITCL_PRESERVE_DECR -1 -#define ITCL_PRESERVE_DELETED 0 - -typedef struct ItclPreserveInfoEntry { - int type; - int line; - const char * fileName; -} ItclPreserveInfoEntry; - -typedef struct ItclPreserveInfo { - size_t refCount; - ClientData clientData; - size_t size; - size_t numEntries; - ItclPreserveInfoEntry *entries; -} ItclPreserveInfo; - -#endif - +#define ITCL_INT_NAMESPACE ITCL_NAMESPACE"::internal" +#define ITCL_INTDICTS_NAMESPACE ITCL_INT_NAMESPACE"::dicts" +#define ITCL_VARIABLES_NAMESPACE ITCL_INT_NAMESPACE"::variables" +#define ITCL_COMMANDS_NAMESPACE ITCL_INT_NAMESPACE"::commands" typedef struct ItclFoundation { Itcl_Stack methodCallStack; @@ -169,7 +160,7 @@ const Tcl_ObjectMetadataType *object_meta_type; /* type for getting the Itcl object info * from a TclOO Tcl_Object */ - Tcl_Object unused1; /* the root object of Itcl */ + Tcl_Object clazzObjectPtr; /* the root object of Itcl */ Tcl_Class clazzClassPtr; /* the root class of Itcl */ struct EnsembleInfo *ensembleInfo; struct ItclClass *currContextIclsPtr; @@ -182,8 +173,7 @@ Tcl_Obj **unparsedObjv; /* options not parsed by ItclExtendedConfigure/-Cget function */ int functionFlags; /* used for creating of ItclMemberCode */ - int unused7; /* used for having a unique key for objects - * for use in mytypemethod etc. */ + int unused7; struct ItclDelegatedOption *currIdoPtr; /* the current delegated option info */ int inOptionHandling; /* used to indicate for type/widget ... @@ -201,7 +191,7 @@ Tcl_Obj *unused3; Tcl_Obj *unused4; Tcl_Obj *infoVarsPtr; - Tcl_Obj *infoVars3Ptr; + Tcl_Obj *unused9; Tcl_Obj *infoVars4Ptr; Tcl_Obj *typeDestructorArgumentPtr; struct ItclObject *lastIoPtr; /* last object constructed */ @@ -232,7 +222,7 @@ #define ITCL_CLASS_IS_DELETED 0x1000 #define ITCL_CLASS_IS_DESTROYED 0x2000 #define ITCL_CLASS_NS_IS_DESTROYED 0x4000 -#define ITCL_CLASS_IS_RENAMED 0x8000 +#define ITCL_CLASS_IS_RENAMED 0x8000 /* unused */ #define ITCL_CLASS_IS_FREED 0x10000 #define ITCL_CLASS_DERIVED_RELEASED 0x20000 #define ITCL_CLASS_NS_TEARDOWN 0x40000 @@ -385,7 +375,6 @@ 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 */ @@ -415,7 +404,6 @@ Tcl_ObjCmdProc *objCmd; /* (objc,objv) C implementation */ } cfunc; ClientData clientData; /* client data for C implementations */ - int refCount; } ItclMemberCode; /* @@ -517,7 +505,6 @@ ClientData tmPtr; /* TclOO methodPtr */ ItclDelegatedFunction *idmPtr; /* if the function is delegated != NULL */ - int refCount; } ItclMemberFunc; /* @@ -593,14 +580,6 @@ #define VAR_TYPE_VARIABLE 1 #define VAR_TYPE_COMMON 2 -typedef struct ItclClassVarInfo { - int type; - int protection; - int varNum; - Tcl_Namespace *nsPtr; - Tcl_Namespace *declaringNsPtr; -} ItclClassVarInfo; - #define CMD_TYPE_METHOD 1 #define CMD_TYPE_PROC 2 @@ -625,7 +604,6 @@ * taken from the resolveVars table, so * it shouldn't be freed. */ int varNum; - ItclClassVarInfo *classVarInfoPtr; Tcl_Var varPtr; } ItclVarLookup; @@ -683,18 +661,9 @@ 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, @@ -725,6 +694,9 @@ ItclClass *iclsPtr); MODULE_SCOPE int ItclInfoInit(Tcl_Interp *interp, ItclObjectInfo *infoPtr); +MODULE_SCOPE Tcl_HashEntry *ItclResolveVarEntry( + ItclClass* iclsPtr, const char *varName); + struct Tcl_ResolvedVarInfo; MODULE_SCOPE int Itcl_ClassCmdResolver(Tcl_Interp *interp, const char* name, Tcl_Namespace *nsPtr, int flags, Tcl_Command *rPtr); @@ -744,6 +716,9 @@ MODULE_SCOPE void ItclProcErrorProc(Tcl_Interp *interp, Tcl_Obj *procNameObj); MODULE_SCOPE int Itcl_CreateOption (Tcl_Interp *interp, ItclClass *iclsPtr, ItclOption *ioptPtr); +MODULE_SCOPE int ItclCreateMethodVariable(Tcl_Interp *interp, + ItclVariable *ivPtr, Tcl_Obj* defaultPtr, Tcl_Obj* callbackPtr, + ItclMethodVariable** imvPtrPtr); MODULE_SCOPE int Itcl_CreateMethodVariable (Tcl_Interp *interp, ItclClass *iclsPtr, Tcl_Obj *name, Tcl_Obj *defaultPtr, Tcl_Obj *callbackPtr, ItclMethodVariable **imvPtr); @@ -819,6 +794,9 @@ ItclClass *iclsPtr, ItclDelegatedFunction *idmPtr); MODULE_SCOPE int ItclClassCreateObject(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); + +MODULE_SCOPE void ItclRestoreInfoVars(ClientData clientData); + MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiMyProcCmd; MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiInstallComponentCmd; MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiCallInstanceCmd; @@ -847,9 +825,6 @@ MODULE_SCOPE ItclRootMethodProc ItclInfoGuts; #include "itcl2TclOO.h" -#ifdef NEW_PROTO_RESOLVER -#include "itclVarsAndCmds.h" -#endif /* * Include all the private API, generated from itcl.decls. diff -Nru itcl4-4.1.2/generic/itclLinkage.c itcl4-4.2.0/generic/itclLinkage.c --- itcl4-4.1.2/generic/itclLinkage.c 2012-08-30 13:56:11.000000000 +0000 +++ itcl4-4.2.0/generic/itclLinkage.c 2019-10-04 16:02:02.000000000 +0000 @@ -74,12 +74,12 @@ * ------------------------------------------------------------------------ */ int -Itcl_RegisterC(interp, name, proc, clientData, deleteProc) - Tcl_Interp *interp; /* interpreter handling this registration */ - const char *name; /* symbolic name for procedure */ - Tcl_CmdProc *proc; /* procedure handling Tcl command */ - ClientData clientData; /* client data associated with proc */ - Tcl_CmdDeleteProc *deleteProc; /* proc called to free up client data */ +Itcl_RegisterC( + Tcl_Interp *interp, /* interpreter handling this registration */ + const char *name, /* symbolic name for procedure */ + Tcl_CmdProc *proc, /* procedure handling Tcl command */ + ClientData clientData, /* client data associated with proc */ + Tcl_CmdDeleteProc *deleteProc) /* proc called to free up client data */ { int newEntry; Tcl_HashEntry *entry; @@ -92,7 +92,7 @@ if (!proc) { Tcl_AppendResult(interp, "initialization error: null pointer for ", "C procedure \"", name, "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -108,7 +108,7 @@ if (cfunc->argCmdProc != NULL && cfunc->argCmdProc != proc) { Tcl_AppendResult(interp, "initialization error: C procedure ", "with name \"", name, "\" already defined", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -124,7 +124,7 @@ cfunc->clientData = clientData; cfunc->deleteProc = deleteProc; - Tcl_SetHashValue(entry, (ClientData)cfunc); + Tcl_SetHashValue(entry, cfunc); return TCL_OK; } @@ -158,12 +158,12 @@ * ------------------------------------------------------------------------ */ int -Itcl_RegisterObjC(interp, name, proc, clientData, deleteProc) - Tcl_Interp *interp; /* interpreter handling this registration */ - const char *name; /* symbolic name for procedure */ - Tcl_ObjCmdProc *proc; /* procedure handling Tcl command */ - ClientData clientData; /* client data associated with proc */ - Tcl_CmdDeleteProc *deleteProc; /* proc called to free up client data */ +Itcl_RegisterObjC( + Tcl_Interp *interp, /* interpreter handling this registration */ + const char *name, /* symbolic name for procedure */ + Tcl_ObjCmdProc *proc, /* procedure handling Tcl command */ + ClientData clientData, /* client data associated with proc */ + Tcl_CmdDeleteProc *deleteProc) /* proc called to free up client data */ { int newEntry; Tcl_HashEntry *entry; @@ -176,7 +176,7 @@ if (!proc) { Tcl_AppendResult(interp, "initialization error: null pointer for ", "C procedure \"", name, "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -192,7 +192,7 @@ if (cfunc->objCmdProc != NULL && cfunc->objCmdProc != proc) { Tcl_AppendResult(interp, "initialization error: C procedure ", "with name \"", name, "\" already defined", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -209,7 +209,7 @@ cfunc->clientData = clientData; cfunc->deleteProc = deleteProc; - Tcl_SetHashValue(entry, (ClientData)cfunc); + Tcl_SetHashValue(entry, cfunc); return TCL_OK; } @@ -244,7 +244,7 @@ if (interp) { procTable = (Tcl_HashTable*)Tcl_GetAssocData(interp, - "itcl_RegC", (Tcl_InterpDeleteProc**)NULL); + "itcl_RegC", NULL); if (procTable) { entry = Tcl_FindHashEntry(procTable, name); @@ -270,8 +270,8 @@ * ------------------------------------------------------------------------ */ static Tcl_HashTable* -ItclGetRegisteredProcs(interp) - Tcl_Interp *interp; /* interpreter handling this registration */ +ItclGetRegisteredProcs( + Tcl_Interp *interp) /* interpreter handling this registration */ { Tcl_HashTable* procTable; @@ -279,13 +279,13 @@ * If the registration table does not yet exist, then create it. */ procTable = (Tcl_HashTable*)Tcl_GetAssocData(interp, "itcl_RegC", - (Tcl_InterpDeleteProc**)NULL); + NULL); if (!procTable) { procTable = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(procTable, TCL_STRING_KEYS); Tcl_SetAssocData(interp, "itcl_RegC", ItclFreeC, - (ClientData)procTable); + procTable); } return procTable; } @@ -301,9 +301,9 @@ * ------------------------------------------------------------------------ */ static void -ItclFreeC(clientData, interp) - ClientData clientData; /* associated data */ - Tcl_Interp *interp; /* intepreter being deleted */ +ItclFreeC( + ClientData clientData, /* associated data */ + Tcl_Interp *interp) /* intepreter being deleted */ { Tcl_HashTable *tablePtr = (Tcl_HashTable*)clientData; Tcl_HashSearch place; diff -Nru itcl4-4.1.2/generic/itclMethod.c itcl4-4.2.0/generic/itclMethod.c --- itcl4-4.1.2/generic/itclMethod.c 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/generic/itclMethod.c 2019-11-03 02:24:15.000000000 +0000 @@ -40,42 +40,8 @@ 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); +static void FreeMemberCode(ItclMemberCode *mcodePtr); -void -ItclPreserveIMF( - ItclMemberFunc *imPtr) -{ - imPtr->refCount++; -} - -void -ItclReleaseIMF( - ClientData clientData) -{ - ItclMemberFunc *imPtr = (ItclMemberFunc *)clientData; - - if (--imPtr->refCount == 0) { - Itcl_DeleteMemberFunc(clientData); - } -} - -void -ItclPreserveMemberCode( - ItclMemberCode *mcodePtr) -{ - mcodePtr->refCount++; -} - -void -ItclReleaseMemberCode( - ItclMemberCode *mcodePtr) -{ - if (--mcodePtr->refCount == 0) { - ItclFreeMemberCode(mcodePtr); - } -} - /* * ------------------------------------------------------------------------ * Itcl_BodyCmd() @@ -121,7 +87,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"", token, " class::func arglist body\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -136,7 +102,7 @@ if (!head || *head == '\0') { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "missing class specifier for body declaration \"", token, "\"", - (char*)NULL); + NULL); status = TCL_ERROR; goto bodyCmdDone; } @@ -171,7 +137,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "function \"", tail, "\" is not defined in class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", - (char*)NULL); + NULL); status = TCL_ERROR; goto bodyCmdDone; } @@ -257,7 +223,7 @@ if ((head == NULL) || (*head == '\0')) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "missing class specifier for body declaration \"", token, "\"", - (char*)NULL); + NULL); status = TCL_ERROR; goto configBodyCmdDone; } @@ -275,7 +241,7 @@ * containing the variable definition is the requested class. */ vlookup = NULL; - entry = Tcl_FindHashEntry(&iclsPtr->resolveVars, tail); + entry = ItclResolveVarEntry(iclsPtr, tail); if (entry) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); if (vlookup->ivPtr->iclsPtr != iclsPtr) { @@ -287,7 +253,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "option \"", tail, "\" is not defined in class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", - (char*)NULL); + NULL); status = TCL_ERROR; goto configBodyCmdDone; } @@ -297,23 +263,23 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "option \"", Tcl_GetString(ivPtr->fullNamePtr), "\" is not a public configuration option", - (char*)NULL); + NULL); status = TCL_ERROR; goto configBodyCmdDone; } token = Tcl_GetString(objv[2]); - if (Itcl_CreateMemberCode(interp, iclsPtr, (char*)NULL, token, + 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; @@ -390,7 +356,7 @@ if (strstr(Tcl_GetString(namePtr),"::")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad method name \"", Tcl_GetString(namePtr), "\"", - (char*)NULL); + NULL); Tcl_DecrRefCount(namePtr); return TCL_ERROR; } @@ -439,7 +405,7 @@ if (strstr(Tcl_GetString(namePtr),"::")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad proc name \"", Tcl_GetString(namePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -500,7 +466,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", Tcl_GetString(namePtr), "\" already defined in class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -517,8 +483,8 @@ /* * 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); @@ -534,7 +500,7 @@ Tcl_IncrRefCount(imPtr->origArgsPtr); } imPtr->codePtr = mcode; - ItclPreserveMemberCode(mcode); + Itcl_PreserveData(mcode); if (imPtr->protection == ITCL_DEFAULT_PROTECT) { imPtr->protection = ITCL_PUBLIC; @@ -661,7 +627,7 @@ */ Tcl_Obj *newBody = Tcl_NewStringObj("", -1); - Tcl_AppendToObj(newBody, + Tcl_AppendToObj(newBody, "[::info object namespace ${this}]::my ItclConstructBase ", -1); Tcl_AppendObjToObj(newBody, iclsPtr->fullNamePtr); Tcl_AppendToObj(newBody, "\n", -1); @@ -676,8 +642,8 @@ imPtr->flags |= ITCL_DESTRUCTOR; } - Tcl_SetHashValue(hPtr, (ClientData)imPtr); - imPtr->refCount = 1; + Tcl_SetHashValue(hPtr, imPtr); + Itcl_PreserveData(imPtr); *imPtrPtr = imPtr; return TCL_OK; @@ -765,9 +731,10 @@ "argument list changed for function \"", Tcl_GetString(imPtr->fullNamePtr), "\": should be \"", argsStr, "\"", - (char*)NULL); + NULL); - Itcl_DeleteMemberCode((char*)mcode); + Itcl_PreserveData(mcode); + Itcl_ReleaseData(mcode); return TCL_ERROR; } @@ -779,7 +746,7 @@ */ Tcl_Obj *newBody = Tcl_NewStringObj("", -1); - Tcl_AppendToObj(newBody, + Tcl_AppendToObj(newBody, "[::info object namespace ${this}]::my ItclConstructBase ", -1); Tcl_AppendObjToObj(newBody, imPtr->iclsPtr->fullNamePtr); Tcl_AppendToObj(newBody, "\n", -1); @@ -793,12 +760,12 @@ /* * 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 = (ClientData)Itcl_NewProcClassMethod(interp, + imPtr->tmPtr = Itcl_NewProcClassMethod(interp, imPtr->iclsPtr->clsPtr, ItclCheckCallMethod, ItclAfterCallMethod, ItclProcErrorProc, imPtr, imPtr->namePtr, mcode->argumentPtr, mcode->bodyPtr, &pmPtr); @@ -860,13 +827,14 @@ /* * 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_DeleteMemberCode((char*)mcode); + Itcl_PreserveData(mcode); + Itcl_ReleaseData(mcode); return TCL_ERROR; } mcode->argcount = argc; @@ -875,12 +843,13 @@ mcode->usagePtr = usagePtr; Tcl_IncrRefCount(mcode->usagePtr); mcode->argumentPtr = Tcl_NewStringObj((const char *)arglist, -1); + Tcl_IncrRefCount(mcode->argumentPtr); if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { haveError = 0; while (argListPtr != NULL) { cPtrPtr = &type_reserved_words[0]; while (*cPtrPtr != NULL) { - if ((argListPtr->namePtr != NULL) && + if ((argListPtr->namePtr != NULL) && (strcmp(Tcl_GetString(argListPtr->namePtr), *cPtrPtr) == 0)) { haveError = 1; @@ -903,12 +872,13 @@ "constructor") == 0)) { startStr = ""; } - Tcl_AppendResult(interp, startStr, + Tcl_AppendResult(interp, startStr, namePtr == NULL ? "??" : Tcl_GetString(namePtr), "'s arglist may not contain \"", *cPtrPtr, "\" explicitly", NULL); - Itcl_DeleteMemberCode((char*)mcode); + Itcl_PreserveData(mcode); + Itcl_ReleaseData(mcode); return TCL_ERROR; } cPtrPtr++; @@ -916,7 +886,6 @@ argListPtr = argListPtr->nextPtr; } } - Tcl_IncrRefCount(mcode->argumentPtr); mcode->flags |= ITCL_ARG_SPEC; } else { argc = 0; @@ -1025,8 +994,9 @@ &cdata)) { Tcl_AppendResult(interp, "no registered C procedure with name \"", - body+1, "\"", (char*)NULL); - Itcl_DeleteMemberCode((char*)mcode); + body+1, "\"", NULL); + Itcl_PreserveData(mcode); + Itcl_ReleaseData(mcode); return TCL_ERROR; } @@ -1080,7 +1050,7 @@ * 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 @@ -1109,7 +1079,7 @@ * is no longer being used. * ------------------------------------------------------------------------ */ -void ItclFreeMemberCode ( +void FreeMemberCode ( ItclMemberCode* mCodePtr) { if (mCodePtr == NULL) { @@ -1127,16 +1097,15 @@ if (mCodePtr->bodyPtr != NULL) { Tcl_DecrRefCount(mCodePtr->bodyPtr); } - /* do NOT free mCodePtr->bodyPtr here !! that is done in TclOO!! */ - ckfree((char*)mCodePtr); + Itcl_Free(mCodePtr); } void Itcl_DeleteMemberCode( - char* cdata) /* pointer to member code definition */ + void* cdata) /* pointer to member code definition */ { - ItclReleaseMemberCode((ItclMemberCode *)cdata); + Itcl_ReleaseData((ItclMemberCode *)cdata); } @@ -1204,7 +1173,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "member function \"", Tcl_GetString(imPtr->fullNamePtr), "\" is not defined and cannot be autoloaded", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -1220,11 +1189,11 @@ int result) { Tcl_Object oPtr; - ItclMemberFunc *imPtr = data[0]; - ItclObject *ioPtr = data[1]; + ItclMemberFunc *imPtr = (ItclMemberFunc *)data[0]; + ItclObject *ioPtr = (ItclObject *)data[1]; int objc = PTR2INT(data[2]); - Tcl_Obj **objv = data[3]; - + Tcl_Obj **objv = (Tcl_Obj **)data[3]; + ItclShowArgs(1, "CallItclObjectCmd", objc, objv); if (ioPtr != NULL) { ioPtr->hadConstructorError = 0; @@ -1291,7 +1260,7 @@ * 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; @@ -1311,12 +1280,12 @@ char **argv; argv = (char**)ckalloc( (unsigned)(objc*sizeof(char*)) ); for (i=0; i < objc; i++) { - argv[i] = Tcl_GetStringFromObj(objv[i], (int*)NULL); + argv[i] = Tcl_GetString(objv[i]); } - + result = (*mcode->cfunc.argCmd)(mcode->clientData, interp, objc, (const char **)argv); - + ckfree((char*)argv); } } @@ -1329,7 +1298,7 @@ } } - ItclReleaseMemberCode(mcode); + Itcl_ReleaseData(mcode); return result; } @@ -1432,13 +1401,13 @@ Tcl_Interp *interp, ItclObject *ioPtr) { - int new; + int isNew; Itcl_Stack *stackPtr; Tcl_CallFrame *framePtr = Itcl_GetUplevelCallFrame(interp, 0); ItclObjectInfo *infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&infoPtr->frameContext, - (char *)framePtr, &new); + (char *)framePtr, &isNew); ItclCallContext *contextPtr = (ItclCallContext *) ckalloc(sizeof(ItclCallContext)); @@ -1446,10 +1415,10 @@ contextPtr->ioPtr = ioPtr; contextPtr->refCount = 1; - if (!new) { + if (!isNew) { Tcl_Panic("frame already has context?!"); } - + stackPtr = (Itcl_Stack *) ckalloc(sizeof(Itcl_Stack)); Itcl_InitStack(stackPtr); Tcl_SetHashValue(hPtr, stackPtr); @@ -1467,7 +1436,7 @@ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&infoPtr->frameContext, (char *)framePtr); Itcl_Stack *stackPtr = (Itcl_Stack *) Tcl_GetHashValue(hPtr); - ItclCallContext *contextPtr = Itcl_PopStack(stackPtr); + ItclCallContext *contextPtr = (ItclCallContext *)Itcl_PopStack(stackPtr); if (Itcl_GetStackSize(stackPtr) > 0) { Tcl_Panic("frame context stack not empty!"); @@ -1475,7 +1444,7 @@ Itcl_DeleteStack(stackPtr); ckfree((char *) stackPtr); Tcl_DeleteHashEntry(hPtr); - if (--contextPtr->refCount) { + if (contextPtr->refCount-- > 1) { Tcl_Panic("frame context ref count not zero!"); } ckfree((char *)contextPtr); @@ -1500,7 +1469,7 @@ if (hPtr) { /* Frame maps to a context stack. */ Itcl_Stack *stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr); - ItclCallContext *contextPtr = Itcl_PeekStack(stackPtr); + ItclCallContext *contextPtr = (ItclCallContext *)Itcl_PeekStack(stackPtr); assert(contextPtr); @@ -1613,10 +1582,10 @@ name = (char *) Tcl_GetCommandName( contextIoPtr->iclsPtr->interp, contextIoPtr->accessCmd); Tcl_AppendStringsToObj(objPtr, name, " ", - Tcl_GetString(imPtr->namePtr), (char*)NULL); + Tcl_GetString(imPtr->namePtr), NULL); } else { Tcl_AppendStringsToObj(objPtr, " ", - Tcl_GetString(imPtr->namePtr), (char*)NULL); + Tcl_GetString(imPtr->namePtr), NULL); } } } else { @@ -1694,7 +1663,7 @@ if (ioPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot access object-specific info without an object context", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -1730,9 +1699,9 @@ * 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; } @@ -1783,18 +1752,18 @@ ItclMemberFunc *imPtr2 = NULL; Tcl_HashEntry *hPtr; Tcl_ObjectContext context; - context = Itcl_GetCallFrameClientData(interp); + context = (Tcl_ObjectContext)Itcl_GetCallFrameClientData(interp); if (context == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't access \"", Tcl_GetString(imPtr->fullNamePtr), "\": ", Itcl_ProtectionStr(imPtr->protection), - " function", (char*)NULL); + " function", NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&imPtr->iclsPtr->infoPtr->procMethods, (char *)Tcl_ObjectContextMethod(context)); if (hPtr != NULL) { - imPtr2 = Tcl_GetHashValue(hPtr); + imPtr2 = (ItclMemberFunc *)Tcl_GetHashValue(hPtr); } if ((imPtr->protection & ITCL_PRIVATE) && (imPtr2 != NULL) && (imPtr->iclsPtr->nsPtr != imPtr2->iclsPtr->nsPtr)) { @@ -1807,7 +1776,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't access \"", Tcl_GetString(imPtr->fullNamePtr), "\": ", Itcl_ProtectionStr(imPtr->protection), - " function", (char*)NULL); + " function", NULL); return TCL_ERROR; } } @@ -1816,11 +1785,11 @@ * 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, (ItclObject*)NULL, + result = Itcl_EvalMemberCode(interp, imPtr, NULL, objc, objv); - ItclReleaseIMF(imPtr); + Itcl_ReleaseData(imPtr); return result; } @@ -1841,10 +1810,10 @@ Tcl_Interp *interp, int result) { - ItclClass *iclsPtr = data[0]; - ItclObject *contextObj = data[1]; + ItclClass *iclsPtr = (ItclClass *)data[0]; + ItclObject *contextObj = (ItclObject *)data[1]; int objc = PTR2INT(data[2]); - Tcl_Obj* const* objv = data[3]; + Tcl_Obj *const *objv = (Tcl_Obj *const *)data[3]; result = Itcl_InvokeMethodIfExists(interp, "constructor", iclsPtr, contextObj, objc, (Tcl_Obj* const*)objv); @@ -1890,7 +1859,7 @@ if (contextClass->initCode) { /* TODO: NRE */ - result = Tcl_EvalObj(interp, contextClass->initCode); + result = Tcl_EvalObjEx(interp, contextClass->initCode, 0); } /* @@ -1906,7 +1875,7 @@ for (elem = Itcl_LastListElem(&contextClass->bases); result == TCL_OK && elem != NULL; elem = Itcl_PrevListElem(elem)) { - + Tcl_HashEntry *entry; ItclClass *iclsPtr = (ItclClass*)Itcl_GetListValue(elem); @@ -2005,7 +1974,7 @@ */ cmdlinePtr = Itcl_CreateArgs(interp, name, objc, objv); - (void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr, + (void) Tcl_ListObjGetElements(NULL, cmdlinePtr, &cmdlinec, &cmdlinev); ItclShowArgs(1, "EMC", cmdlinec, cmdlinev); @@ -2013,7 +1982,7 @@ * 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); @@ -2021,7 +1990,7 @@ } result = Itcl_EvalMemberCode(interp, imPtr, contextObjectPtr, cmdlinec, cmdlinev); - ItclReleaseIMF(imPtr); + Itcl_ReleaseData(imPtr); Tcl_DecrRefCount(cmdlinePtr); } else { if (contextClassPtr->flags & @@ -2132,7 +2101,7 @@ if (hPtr == NULL) { return NULL; } - iclsPtr = Tcl_GetHashValue(hPtr); + iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); objPtr = Tcl_NewStringObj(cmdName, -1); hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr); Tcl_DecrRefCount(objPtr); @@ -2249,14 +2218,14 @@ infoPtr = iclsPtr->infoPtr; hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); if (hPtr != NULL) { - iclsPtr = Tcl_GetHashValue(hPtr); + iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); } - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, varName); + hPtr = ItclResolveVarEntry(iclsPtr, varName); if (hPtr == NULL) { /* no class/object variable */ return NULL; } - ivlPtr = Tcl_GetHashValue(hPtr); + ivlPtr = (ItclVarLookup *)Tcl_GetHashValue(hPtr); if (ivlPtr == NULL) { return NULL; } @@ -2281,7 +2250,7 @@ } } if (hPtr != NULL) { - varPtr = Tcl_GetHashValue(hPtr); + varPtr = (Tcl_Var)Tcl_GetHashValue(hPtr); } return varPtr; } @@ -2351,7 +2320,7 @@ oPtr = NULL; hPtr = NULL; imPtr = (ItclMemberFunc *)clientData; - ItclPreserveIMF(imPtr); + Itcl_PreserveData(imPtr); if (imPtr->flags & ITCL_CONSTRUCTOR) { ioPtr = imPtr->iclsPtr->infoPtr->currIoPtr; } else { @@ -2374,8 +2343,8 @@ result = TCL_ERROR; goto finishReturn; } - oPtr = Tcl_ObjectContextObject(contextPtr); - ioPtr = Tcl_ObjectGetMetadata(oPtr, + oPtr = Tcl_ObjectContextObject(contextPtr); + ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, imPtr->iclsPtr->infoPtr->object_meta_type); } if ((imPtr->codePtr != NULL) && @@ -2419,7 +2388,7 @@ if (ioPtr != NULL) { hPtr = Tcl_CreateHashEntry(&ioPtr->contextCache, (char *)imPtr, &isNew); if (!isNew) { - callContextPtr2 = Tcl_GetHashValue(hPtr); + callContextPtr2 = (ItclCallContext *)Tcl_GetHashValue(hPtr); if (callContextPtr2->refCount == 0) { callContextPtr = callContextPtr2; callContextPtr->objectFlags = ioPtr->flags; @@ -2428,7 +2397,7 @@ callContextPtr->imPtr = imPtr; callContextPtr->refCount = 1; } else { - if ((callContextPtr2->objectFlags == ioPtr->flags) + if ((callContextPtr2->objectFlags == ioPtr->flags) && (callContextPtr2->nsPtr == currNsPtr)) { callContextPtr = callContextPtr2; callContextPtr->refCount++; @@ -2488,7 +2457,7 @@ if (ioPtr != NULL) { ioPtr->callRefCount++; - ItclPreserveObject(ioPtr); + Itcl_PreserveData(ioPtr); } imPtr->iclsPtr->callRefCount++; if (!imPtr->iclsPtr->infoPtr->useOldResolvers) { @@ -2501,7 +2470,7 @@ } return result; finishReturn: - ItclReleaseIMF(imPtr); + Itcl_ReleaseData(imPtr); return result; } @@ -2533,11 +2502,11 @@ ItclObjectInfo *infoPtr = imPtr->infoPtr; Tcl_CallFrame *framePtr; Itcl_Stack *stackPtr; - + hPtr = Tcl_FindHashEntry(&infoPtr->frameContext, (char *)contextPtr); assert(hPtr); stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr); - framePtr = Itcl_PopStack(stackPtr); + framePtr = (Tcl_CallFrame *)Itcl_PopStack(stackPtr); if (Itcl_GetStackSize(stackPtr) == 0) { Itcl_DeleteStack(stackPtr); ckfree((char *) stackPtr); @@ -2547,7 +2516,7 @@ hPtr = Tcl_FindHashEntry(&infoPtr->frameContext, (char *)framePtr); assert(hPtr); stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr); - callContextPtr = Itcl_PopStack(stackPtr); + callContextPtr = (ItclCallContext *)Itcl_PopStack(stackPtr); if (Itcl_GetStackSize(stackPtr) == 0) { Itcl_DeleteStack(stackPtr); ckfree((char *) stackPtr); @@ -2594,23 +2563,22 @@ ItclDeleteObjectVariablesNamespace(interp, ioPtr); } } - - callContextPtr->refCount--; - if (callContextPtr->refCount == 0) { + + 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; } @@ -2643,7 +2611,7 @@ /* Frame maps to a context stack. */ stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr); - callContextPtr = Itcl_PeekStack(stackPtr); + callContextPtr = (ItclCallContext *)Itcl_PeekStack(stackPtr); if (callContextPtr == NULL) { return; @@ -2709,25 +2677,27 @@ dictPtr = Tcl_GetReturnOptions(interp, TCL_ERROR); if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr) != TCL_OK) { /* how should we handle an error ? */ + Tcl_DecrRefCount(dictPtr); Tcl_DecrRefCount(keyPtr); Tcl_DecrRefCount(objPtr); return; } if (valuePtr == NULL) { /* how should we handle an error ? */ + Tcl_DecrRefCount(dictPtr); Tcl_DecrRefCount(keyPtr); Tcl_DecrRefCount(objPtr); return; } if (Tcl_GetIntFromObj(interp, valuePtr, &lineNo) != TCL_OK) { /* how should we handle an error ? */ + Tcl_DecrRefCount(dictPtr); Tcl_DecrRefCount(keyPtr); - Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(objPtr); return; } + Tcl_DecrRefCount(dictPtr); Tcl_DecrRefCount(keyPtr); - Tcl_DecrRefCount(valuePtr); Tcl_AppendToObj(objPtr, "body line ", -1); sprintf(num, "%d", lineNo); Tcl_AppendToObj(objPtr, num, -1); diff -Nru itcl4-4.1.2/generic/itclMigrate2TclCore.c itcl4-4.2.0/generic/itclMigrate2TclCore.c --- itcl4-4.1.2/generic/itclMigrate2TclCore.c 2017-12-08 13:09:27.000000000 +0000 +++ itcl4-4.2.0/generic/itclMigrate2TclCore.c 2019-10-04 16:02:02.000000000 +0000 @@ -55,14 +55,14 @@ const char *varName) { Var *varPtr = NULL; - int new; + int isNew; if ((nsPtr == NULL) || (varName == NULL)) { return NULL; } varPtr = TclVarHashCreateVar(&((Namespace *)nsPtr)->varTable, - varName, &new); + varName, &isNew); TclSetVarNamespaceVar(varPtr); return (Tcl_Var)varPtr; } @@ -233,7 +233,7 @@ for (;localPtr != NULL; localPtr = localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { - register char *localName = localPtr->name; + char *localName = localPtr->name; if ((name[0] == localName[0]) && (nameLen == localPtr->nameLength) && (strcmp(name, localName) == 0)) { @@ -244,44 +244,3 @@ } return 0; } - -int -Itcl_IsCallFrameLinkVar( - Tcl_Interp *interp, - const char *name) -{ - CallFrame *varFramePtr = ((Interp *)interp)->framePtr; - Proc *procPtr; - - if (varFramePtr == NULL) { - return 0; - } - if (!varFramePtr->isProcCallFrame) { - return 0; - } - procPtr = varFramePtr->procPtr; - /* - * Search through compiled locals first... - */ - if (procPtr) { - CompiledLocal *localPtr = procPtr->firstLocalPtr; - int nameLen = strlen(name); - - for (;localPtr != NULL; localPtr = localPtr->nextPtr) { - if (TclIsVarLink(localPtr)) { - register char *localName = localPtr->name; - if ((name[0] == localName[0]) - && (nameLen == localPtr->nameLength) - && (strcmp(name, localName) == 0)) { - return 1; - } - } - } - } - return 0; -} - -int -Itcl_IsVarLink(Tcl_Var varPtr) { - return TclIsVarLink((Var *)varPtr); -} diff -Nru itcl4-4.1.2/generic/itclMigrate2TclCore.h itcl4-4.2.0/generic/itclMigrate2TclCore.h --- itcl4-4.1.2/generic/itclMigrate2TclCore.h 2016-06-21 11:23:52.000000000 +0000 +++ itcl4-4.2.0/generic/itclMigrate2TclCore.h 2019-10-04 16:02:02.000000000 +0000 @@ -71,16 +71,12 @@ #define _TCL_PROC_DEFINED 1 #endif -#define Tcl_SetProcCmd _Tcl_SetProcCmd - MODULE_SCOPE Tcl_Var Tcl_NewNamespaceVar(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *varName); MODULE_SCOPE void Itcl_PreserveVar(Tcl_Var var); MODULE_SCOPE void Itcl_ReleaseVar(Tcl_Var var); MODULE_SCOPE int Itcl_IsCallFrameArgument(Tcl_Interp *interp, const char *name); MODULE_SCOPE int Itcl_GetCallVarFrameObjc(Tcl_Interp *interp); -MODULE_SCOPE int Itcl_IsVarLink(Tcl_Var var); -MODULE_SCOPE int Itcl_IsCallFrameLinkVar(Tcl_Interp *interp, const char *name); MODULE_SCOPE Tcl_Obj * const * Itcl_GetCallVarFrameObjv(Tcl_Interp *interp); #define Tcl_SetNamespaceResolver _Tcl_SetNamespaceResolver MODULE_SCOPE int _Tcl_SetNamespaceResolver(Tcl_Namespace *nsPtr, diff -Nru itcl4-4.1.2/generic/itclObject.c itcl4-4.2.0/generic/itclObject.c --- itcl4-4.1.2/generic/itclObject.c 2017-12-08 13:09:27.000000000 +0000 +++ itcl4-4.2.0/generic/itclObject.c 2019-11-03 02:24:15.000000000 +0000 @@ -53,7 +53,7 @@ const char *name1, const char *name2, int flags); static void ItclDestroyObject(ClientData clientData); -static void ItclFreeObject(char * clientData); +static void FreeObject(char *cdata); static int ItclDestructBase(Tcl_Interp *interp, ItclObject *contextObj, ItclClass *contextClass, int flags); @@ -70,24 +70,6 @@ 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 == 0) { - ItclFreeObject((char *) clientData); - } -} - /* * ------------------------------------------------------------------------ @@ -105,7 +87,7 @@ if (ioPtr == NULL) return; /* Safety */ if (ioPtr->oPtr == NULL) return; /* Safety */ - + hPtr = Tcl_FindHashEntry(&ioPtr->infoPtr->instances, (Tcl_GetObjectNamespace(ioPtr->oPtr))->fullName); @@ -132,7 +114,7 @@ const char *newName, /* Always NULL ??. not for itk!! */ int flags) /* Why was the object deleted? */ { - ItclObject *ioPtr = clientData; + ItclObject *ioPtr = (ItclObject *)clientData; Itcl_InterpState istate; if (newName != NULL) { @@ -265,8 +247,8 @@ /* * 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, (Tcl_FreeProc *)FreeObject); ioPtr->iclsPtr = iclsPtr; ioPtr->interp = interp; ioPtr->infoPtr = infoPtr; @@ -278,7 +260,7 @@ 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; } @@ -287,7 +269,7 @@ * 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); @@ -317,7 +299,7 @@ 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 @@ -330,13 +312,13 @@ */ if (ItclInitObjectVariables(interp, ioPtr, iclsPtr) != TCL_OK) { - ioPtr->hadConstructorError = 11; + ioPtr->hadConstructorError = 11; result = TCL_ERROR; goto errorReturn; } if (ItclInitObjectCommands(interp, ioPtr, iclsPtr, name) != TCL_OK) { Tcl_AppendResult(interp, "error in ItclInitObjectCommands", NULL); - ioPtr->hadConstructorError = 12; + ioPtr->hadConstructorError = 12; result = TCL_ERROR; goto errorReturn; } @@ -348,7 +330,7 @@ if (ItclInitObjectOptions(interp, ioPtr, iclsPtr) != TCL_OK) { Tcl_AppendResult(interp, "error in ItclInitObjectOptions", NULL); - ioPtr->hadConstructorError = 13; + ioPtr->hadConstructorError = 13; result = TCL_ERROR; goto errorReturn; } @@ -357,7 +339,7 @@ != TCL_OK) { Tcl_AppendResult(interp, "error in ItclInitObjectMethodVariables", NULL); - ioPtr->hadConstructorError = 14; + ioPtr->hadConstructorError = 14; result = TCL_ERROR; goto errorReturn; } @@ -405,7 +387,7 @@ Tcl_DecrRefCount(newObjv[4]); ckfree((char *)newObjv); if (result != TCL_OK) { - ioPtr->hadConstructorError = 15; + ioPtr->hadConstructorError = 15; goto errorReturn; } } @@ -454,7 +436,7 @@ ioPtr->accessCmd = Tcl_GetObjectCommand(ioPtr->oPtr); Tcl_GetCommandInfoFromToken(ioPtr->accessCmd, &cmdInfo); - cmdInfo.deleteProc = (void *)ItclDestroyObject; + cmdInfo.deleteProc = ItclDestroyObject; cmdInfo.deleteData = ioPtr; Tcl_SetCommandInfoFromToken(ioPtr->accessCmd, &cmdInfo); ioPtr->resolvePtr = (Tcl_Resolve *)ckalloc(sizeof(Tcl_Resolve)); @@ -472,18 +454,18 @@ /* make the object known, if it is used in the constructor already! */ hPtr = Tcl_CreateHashEntry(&iclsPtr->infoPtr->objectCmds, (char*)ioPtr->accessCmd, &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)ioPtr); + Tcl_SetHashValue(hPtr, ioPtr); hPtr = Tcl_CreateHashEntry(&iclsPtr->infoPtr->objects, (char*)ioPtr, &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)ioPtr); + Tcl_SetHashValue(hPtr, ioPtr); /* Use the TclOO object namespaces as a unique key in case the * object is renamed. Used by mytypemethod, etc. */ hPtr = Tcl_CreateHashEntry(&iclsPtr->infoPtr->instances, (Tcl_GetObjectNamespace(ioPtr->oPtr))->fullName, &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)ioPtr); + Tcl_SetHashValue(hPtr, ioPtr); /* * Now construct the object. Look for a constructor in the @@ -512,7 +494,7 @@ 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 @@ -561,7 +543,7 @@ } result = Itcl_RestoreInterpState(interp, istate); /* need this for 2 ReleaseData at errorReturn!! */ - ItclPreserveObject(ioPtr); + Itcl_PreserveData(ioPtr); goto errorReturn; } @@ -580,7 +562,7 @@ TCL_TRACE_RENAME|TCL_TRACE_DELETE, ObjectRenamedTrace, ioPtr); } if (iclsPtr->flags & (ITCL_WIDGETADAPTOR)) { - /* + /* * set all the init values for options */ @@ -613,7 +595,7 @@ } result = Itcl_RestoreInterpState(interp, istate); /* need this for 2 ReleaseData at errorReturn!! */ - ItclPreserveObject(ioPtr); + Itcl_PreserveData(ioPtr); goto errorReturn; } } @@ -637,10 +619,10 @@ } hPtr = Tcl_CreateHashEntry(&iclsPtr->infoPtr->objectCmds, (char*)ioPtr->accessCmd, &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)ioPtr); + Tcl_SetHashValue(hPtr, ioPtr); hPtr = Tcl_CreateHashEntry(&iclsPtr->infoPtr->objects, (char*)ioPtr, &newEntry); - Tcl_SetHashValue(hPtr, (ClientData)ioPtr); + Tcl_SetHashValue(hPtr, ioPtr); /* * This is an inelegant hack, left behind until the need for it @@ -651,7 +633,7 @@ & (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { Tcl_NewInstanceMethod(interp, ioPtr->oPtr, Tcl_NewStringObj("unknown", -1), 0, - &itclRootMethodType, ItclUnknownGuts); + &itclRootMethodType, (void *)ItclUnknownGuts); } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { @@ -705,7 +687,7 @@ ckfree((char*)ioPtr->constructed); ioPtr->constructed = NULL; ItclAddObjectsDictInfo(interp, ioPtr); - ItclReleaseObject(ioPtr); + Itcl_ReleaseData(ioPtr); return result; errorReturn: @@ -730,8 +712,8 @@ ioPtr->constructed = NULL; } ItclDeleteObjectVariablesNamespace(interp, ioPtr); - ItclReleaseObject(ioPtr); - ItclReleaseObject(ioPtr); + Itcl_ReleaseData(ioPtr); + Itcl_ReleaseData(ioPtr); return result; } @@ -751,81 +733,6 @@ ItclClass *iclsPtr, const char *name) { -#ifdef NEW_PROTO_RESOLVER - Tcl_HashEntry *hPtr; - Tcl_HashEntry *entry; - Tcl_HashSearch place; - Tcl_Command cmdPtr; - Tcl_Obj *objPtr; - Tcl_Namespace *nsPtr; - ItclClass *iclsPtr2; - ItclClass *lastIclsPtr; - ItclHierIter hier; - ItclMemberFunc *imPtr; - ItclCmdLookup *clookup; - ItclCmdLookup *info_clookup; - - info_clookup = NULL; - lastIclsPtr = NULL; - Tcl_ResetResult(interp); - Itcl_InitHierIter(&hier, iclsPtr); - iclsPtr2 = Itcl_AdvanceHierIter(&hier); - while (iclsPtr2 != NULL) { - entry = Tcl_FirstHashEntry(&iclsPtr2->functions, &place); - while (entry) { - imPtr = (ItclMemberFunc *)Tcl_GetHashValue(entry); - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, - (char *)imPtr->namePtr); - clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); - cmdPtr = imPtr->accessCmd; - nsPtr = iclsPtr->nsPtr; - if ((imPtr->flags & ITCL_COMMON) == 0) { - cmdPtr = Itcl_RegisterObjectCommand(interp, ioPtr, - Tcl_GetString(imPtr->namePtr), clookup->classCmdInfoPtr, - cmdPtr, iclsPtr->nsPtr); - } else { - cmdPtr = Itcl_RegisterObjectCommand(interp, ioPtr, - Tcl_GetString(imPtr->namePtr), clookup->classCmdInfoPtr, - cmdPtr, iclsPtr->nsPtr); - } - entry = Tcl_NextHashEntry(&place); - } - lastIclsPtr = iclsPtr2; - iclsPtr2 = Itcl_AdvanceHierIter(&hier); - } - - /* add some builtin functions to every class!! */ - Itcl_InitHierIter(&hier, iclsPtr); - iclsPtr2 = Itcl_AdvanceHierIter(&hier); - while (iclsPtr2 != NULL) { - objPtr = Tcl_NewStringObj("info", -1); - hPtr = Tcl_FindHashEntry(&iclsPtr2->resolveCmds, objPtr); - Tcl_DecrRefCount(objPtr); - if (hPtr != NULL) { - clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); - cmdPtr = Itcl_RegisterObjectCommand(interp, ioPtr, "info", - clookup->classCmdInfoPtr, cmdPtr, iclsPtr->nsPtr); - } - objPtr = Tcl_NewStringObj("isa", -1); - hPtr = Tcl_FindHashEntry(&iclsPtr2->resolveCmds, objPtr); - Tcl_DecrRefCount(objPtr); - if (hPtr != NULL) { - clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); - cmdPtr = Itcl_RegisterObjectCommand(interp, ioPtr, "isa", - clookup->classCmdInfoPtr, cmdPtr, iclsPtr->nsPtr); - } - objPtr = Tcl_NewStringObj("setget", -1); - hPtr = Tcl_FindHashEntry(&iclsPtr2->resolveCmds, objPtr); - Tcl_DecrRefCount(objPtr); - if (hPtr != NULL) { - clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); - cmdPtr = Itcl_RegisterObjectCommand(interp, ioPtr, "setget", - clookup->classCmdInfoPtr, cmdPtr, iclsPtr->nsPtr); - } - iclsPtr2 = Itcl_AdvanceHierIter(&hier); - } - Itcl_DeleteHierIter(&hier); -#endif return TCL_OK; } @@ -857,9 +764,6 @@ ItclHierIter hier; ItclVariable *ivPtr; ItclComponent *icPtr; -#ifdef NEW_PROTO_RESOLVER - ItclVarLookup *vlookup; -#endif const char *varName; const char *inheritComponentName; int itclOptionsIsSet; @@ -920,7 +824,7 @@ Tcl_TraceVar2(interp, "itcl_options", NULL, TCL_TRACE_READS|TCL_TRACE_WRITES, - ItclTraceOptionVar, (ClientData)ioPtr); + ItclTraceOptionVar, ioPtr); Itcl_PopCallFrame(interp); if (Itcl_PushCallFrame(interp, &frame, varNsPtr, /*isProcCallFrame*/0) != TCL_OK) { @@ -938,7 +842,7 @@ Tcl_GetString(ivPtr->iclsPtr->namePtr), NULL); goto errorCleanup; } - icPtr = Tcl_GetHashValue(hPtr2); + icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr2); if (icPtr->flags & ITCL_COMPONENT_INHERIT) { if (inheritComponentName != NULL) { Tcl_AppendResult(interp, "object \"", @@ -949,7 +853,7 @@ "\" now component \"", Tcl_GetString(icPtr->namePtr), "\"", NULL); goto errorCleanup; - + } else { inheritComponentName = Tcl_GetString(icPtr->namePtr); } @@ -969,29 +873,19 @@ goto errorCleanup; } } - hPtr2 = Tcl_FindHashEntry(&ivPtr->iclsPtr->resolveVars, varName); + hPtr2 = ItclResolveVarEntry(ivPtr->iclsPtr, varName); if (hPtr2 == NULL) { hPtr = Tcl_NextHashEntry(&place); continue; } -#ifdef NEW_PROTO_RESOLVER - vlookup = Tcl_GetHashValue(hPtr2); -#endif if ((ivPtr->flags & ITCL_COMMON) == 0) { -#ifndef NEW_PROTO_RESOLVER varPtr = Tcl_NewNamespaceVar(interp, varNsPtr, Tcl_GetString(ivPtr->namePtr)); -#else - varPtr = Itcl_RegisterObjectVariable(interp, ioPtr, - Tcl_GetString(ivPtr->namePtr), vlookup->classVarInfoPtr, - NULL, varNsPtr); -#endif hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectVariables, (char *)ivPtr, &isNew); if (isNew) { Itcl_PreserveVar(varPtr); Tcl_SetHashValue(hPtr2, varPtr); - } else { } if (ivPtr->flags & (ITCL_THIS_VAR|ITCL_TYPE_VAR| ITCL_SELF_VAR|ITCL_SELFNS_VAR|ITCL_WIN_VAR)) { @@ -1006,31 +900,31 @@ if (ivPtr->flags & ITCL_THIS_VAR) { Tcl_TraceVar2(interp, varName, NULL, TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceThisVar, - (ClientData)ioPtr); + ioPtr); isDone = 1; } if (!isDone && ivPtr->flags & ITCL_TYPE_VAR) { Tcl_TraceVar2(interp, varName, NULL, TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceTypeVar, - (ClientData)ioPtr); + ioPtr); isDone = 1; } if (!isDone && ivPtr->flags & ITCL_SELF_VAR) { Tcl_TraceVar2(interp, varName, NULL, TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceSelfVar, - (ClientData)ioPtr); + ioPtr); isDone = 1; } if (!isDone && ivPtr->flags & ITCL_SELFNS_VAR) { Tcl_TraceVar2(interp, varName, NULL, TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceSelfnsVar, - (ClientData)ioPtr); + ioPtr); isDone = 1; } if (!isDone && ivPtr->flags & ITCL_WIN_VAR) { Tcl_TraceVar2(interp, varName, NULL, TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceWinVar, - (ClientData)ioPtr); + ioPtr); isDone = 1; } } else { @@ -1038,11 +932,11 @@ Tcl_TraceVar2(interp, varName, NULL, TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceItclHullVar, - (ClientData)ioPtr); + ioPtr); } else { if (ivPtr->init != NULL) { - if (Tcl_SetVar(interp, - Tcl_GetString(ivPtr->namePtr), + if (Tcl_SetVar2(interp, + Tcl_GetString(ivPtr->namePtr), NULL, Tcl_GetString(ivPtr->init), TCL_NAMESPACE_ONLY) == NULL) { goto errorCleanup; @@ -1071,7 +965,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot initialize variable \"", Tcl_GetString(ivPtr->namePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } i++; @@ -1086,26 +980,19 @@ Tcl_TraceVar2(interp, varName, NULL, TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceItclHullVar, - (ClientData)ioPtr); + ioPtr); } hPtr2 = Tcl_FindHashEntry(&iclsPtr2->classCommons, (char *)ivPtr); if (hPtr2 == NULL) { goto errorCleanup; } - varPtr = Tcl_GetHashValue(hPtr2); + varPtr = (Tcl_Var)Tcl_GetHashValue(hPtr2); hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectVariables, (char *)ivPtr, &isNew); if (isNew) { Itcl_PreserveVar(varPtr); Tcl_SetHashValue(hPtr2, varPtr); - } else { -#ifdef NEW_PROTO_RESOLVER - varPtr = Itcl_RegisterObjectVariable(interp, ioPtr, - Tcl_GetString(ivPtr->namePtr), - vlookup->classVarInfoPtr, - varPtr, varNsPtr); -#endif } if (ivPtr->flags & ITCL_COMPONENT_VAR) { if (ivPtr->flags & ITCL_COMMON) { @@ -1121,19 +1008,19 @@ Tcl_TraceVar2(interp, Tcl_GetString(objPtr2), NULL, TCL_TRACE_WRITES, ItclTraceItclHullVar, - (ClientData)ioPtr); + ioPtr); } else { Tcl_TraceVar2(interp, Tcl_GetString(objPtr2), NULL, TCL_TRACE_WRITES, ItclTraceComponentVar, - (ClientData)ioPtr); + ioPtr); } Tcl_DecrRefCount(objPtr2); } else { Tcl_TraceVar2(interp, varName, NULL, TCL_TRACE_WRITES, ItclTraceComponentVar, - (ClientData)ioPtr); + ioPtr); } } } @@ -1228,7 +1115,7 @@ Tcl_TraceVar2(interp, "itcl_options", NULL, TCL_TRACE_READS|TCL_TRACE_WRITES, - ItclTraceOptionVar, (ClientData)ioPtr); + ItclTraceOptionVar, ioPtr); } Itcl_PopCallFrame(interp); } @@ -1320,13 +1207,13 @@ 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; @@ -1350,7 +1237,7 @@ 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); @@ -1359,7 +1246,7 @@ contextIoPtr->oPtr = NULL; contextIoPtr->accessCmd = NULL; - ItclReleaseObject(contextIoPtr); + Itcl_ReleaseData(contextIoPtr); return TCL_OK; } @@ -1396,7 +1283,7 @@ Tcl_Interp *interp, int result) { - ItclObject *contextIoPtr = data[0]; + ItclObject *contextIoPtr = (ItclObject *)data[0]; if (result == TCL_OK) { ItclDeleteObjectVariablesNamespace(interp, contextIoPtr); Tcl_ResetResult(interp); @@ -1415,7 +1302,7 @@ int result) { Tcl_Obj *objPtr; - ItclObject *contextIoPtr = data[0]; + ItclObject *contextIoPtr = (ItclObject *)data[0]; int flags = PTR2INT(data[1]); if (result != TCL_OK) { @@ -1470,7 +1357,7 @@ if ((flags & ITCL_IGNORE_ERRS) == 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't delete an object while it is being destructed", - (char*)NULL); + NULL); return TCL_ERROR; } return TCL_OK; @@ -1538,7 +1425,7 @@ if (Tcl_FindHashEntry(contextIoPtr->destructed, (char *)contextIclsPtr->namePtr) == NULL) { result = Itcl_InvokeMethodIfExists(interp, "destructor", - contextIclsPtr, contextIoPtr, 0, (Tcl_Obj* const*)NULL); + contextIclsPtr, contextIoPtr, 0, NULL); if (result != TCL_OK) { return TCL_ERROR; } @@ -1612,7 +1499,7 @@ if (Tcl_GetCommandInfoFromToken(cmd, &cmdInfo) != 1) { *roPtr = NULL; } - *roPtr = cmdInfo.deleteData; + *roPtr = (ItclObject *)cmdInfo.deleteData; } else { *roPtr = NULL; } @@ -1728,7 +1615,7 @@ Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot access object-specific info without an object context", - (char*)NULL); + NULL); return NULL; } @@ -1739,9 +1626,9 @@ iclsPtr = contextIclsPtr; } ivPtr = NULL; - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, (char *)name1); + hPtr = ItclResolveVarEntry(iclsPtr, (char *)name1); if (hPtr != NULL) { - vlookup = Tcl_GetHashValue(hPtr); + vlookup = (ItclVarLookup *)Tcl_GetHashValue(hPtr); ivPtr = vlookup->ivPtr; /* * Install the object context and access the data member @@ -1750,11 +1637,11 @@ hPtr = Tcl_FindHashEntry(&contextIoPtr->objectVariables, (char *)ivPtr); if (hPtr) { Tcl_Obj *varName = Tcl_NewObj(); - Tcl_Var varPtr = Tcl_GetHashValue(hPtr); + Tcl_Var varPtr = (Tcl_Var)Tcl_GetHashValue(hPtr); Tcl_GetVariableFullName(interp, varPtr, varName); val = Tcl_GetVar2(interp, Tcl_GetString(varName), name2, - TCL_LEAVE_ERR_MSG); + TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); Tcl_DecrRefCount(varName); if (val) { return val; @@ -1841,7 +1728,7 @@ Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot access object-specific info without an object context", - (char*)NULL); + NULL); return NULL; } @@ -1946,7 +1833,7 @@ Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot access object-specific info without an object context", - (char*)NULL); + NULL); return NULL; } /* get the variable definition to check if that is an ITCL_COMMON */ @@ -1955,9 +1842,9 @@ } else { iclsPtr = contextIclsPtr; } - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, (char *)name1); + hPtr = ItclResolveVarEntry(iclsPtr, (char *)name1); if (hPtr != NULL) { - vlookup = Tcl_GetHashValue(hPtr); + vlookup = (ItclVarLookup *)Tcl_GetHashValue(hPtr); ivPtr = vlookup->ivPtr; } else { return NULL; @@ -1970,7 +1857,7 @@ hPtr = Tcl_FindHashEntry(&contextIoPtr->objectVariables, (char *)ivPtr); if (hPtr) { Tcl_Obj *varName = Tcl_NewObj(); - Tcl_Var varPtr = Tcl_GetHashValue(hPtr); + Tcl_Var varPtr = (Tcl_Var)Tcl_GetHashValue(hPtr); Tcl_GetVariableFullName(interp, varPtr, varName); val = Tcl_SetVar2(interp, Tcl_GetString(varName), name2, value, @@ -2056,7 +1943,7 @@ if (contextIoPtr == NULL) { resultPtr = Tcl_GetObjResult(interp); - infoPtr = (ClientData)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); if (infoPtr == NULL) { Tcl_AppendResult(interp, " PANIC cannot get Itcl AssocData in ItclReportObjectUsage", NULL); return; @@ -2069,7 +1956,7 @@ entry = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)contextNsPtr); if (entry) { - iclsPtr = Tcl_GetHashValue(entry); + iclsPtr = (ItclClass *)Tcl_GetHashValue(entry); } if (iclsPtr == NULL) { @@ -2134,7 +2021,7 @@ cmp = strcmp(Tcl_GetString(imPtr->namePtr), Tcl_GetString(cmpFunc->namePtr)); if (cmp < 0) { - Itcl_InsertListElem(elem, (ClientData)imPtr); + Itcl_InsertListElem(elem, imPtr); imPtr = NULL; break; } else { @@ -2146,7 +2033,7 @@ elem = Itcl_NextListElem(elem); } if (imPtr) { - Itcl_AppendList(&cmdList, (ClientData)imPtr); + Itcl_AppendList(&cmdList, imPtr); } } entry = Tcl_NextHashEntry(&place); @@ -2209,7 +2096,7 @@ contextIoPtr->accessCmd, objPtr); } objName = Tcl_GetString(objPtr); - Tcl_SetVar(interp, (const char *)name1, objName, 0); + Tcl_SetVar2(interp, name1, NULL, objName, 0); Tcl_DecrRefCount(objPtr); return NULL; @@ -2219,7 +2106,7 @@ * Handle write traces on "this" */ if ((flags & TCL_TRACE_WRITES) != 0) { - return "variable \"this\" cannot be modified"; + return (char *)"variable \"this\" cannot be modified"; } return NULL; } @@ -2263,11 +2150,11 @@ /* a window path name must not contain namespace parts !! */ Itcl_ParseNamespPath(Tcl_GetString(contextIoPtr->origNamePtr), &buffer, &head, &tail); if (tail == NULL) { - return " INTERNAL ERROR tail == NULL in ItclTraceThisVar for win"; + return (char *)" INTERNAL ERROR tail == NULL in ItclTraceThisVar for win"; } Tcl_SetStringObj(objPtr, tail, -1); objName = Tcl_GetString(objPtr); - Tcl_SetVar(interp, (const char *)name1, objName, 0); + Tcl_SetVar2(interp, name1, NULL, objName, 0); Tcl_DecrRefCount(objPtr); return NULL; @@ -2278,7 +2165,7 @@ */ if ((flags & TCL_TRACE_WRITES) != 0) { if (!(contextIoPtr->iclsPtr->flags & ITCL_ECLASS)) { - return "variable \"win\" cannot be modified"; + return (char *)"variable \"win\" cannot be modified"; } } return NULL; @@ -2320,7 +2207,7 @@ Tcl_SetStringObj(objPtr, Tcl_GetCurrentNamespace(contextIoPtr->iclsPtr->interp)->fullName, -1); objName = Tcl_GetString(objPtr); - Tcl_SetVar(interp, (const char *)name1, objName, 0); + Tcl_SetVar2(interp, name1, NULL, objName, 0); Tcl_DecrRefCount(objPtr); return NULL; @@ -2330,7 +2217,7 @@ * Handle write traces on "type" */ if ((flags & TCL_TRACE_WRITES) != 0) { - return "variable \"type\" cannot be modified"; + return (char *)"variable \"type\" cannot be modified"; } return NULL; } @@ -2387,7 +2274,7 @@ contextIoPtr->accessCmd, objPtr); } objName = Tcl_GetString(objPtr); - Tcl_SetVar(interp, (const char *)name1, objName, 0); + Tcl_SetVar2(interp, name1, NULL, objName, 0); Tcl_DecrRefCount(objPtr); return NULL; @@ -2397,7 +2284,7 @@ * Handle write traces on "self" */ if ((flags & TCL_TRACE_WRITES) != 0) { - return "variable \"self\" cannot be modified"; + return (char *)"variable \"self\" cannot be modified"; } return NULL; } @@ -2439,7 +2326,7 @@ Tcl_AppendToObj(objPtr, Tcl_GetString(contextIoPtr->iclsPtr->fullNamePtr), -1); objName = Tcl_GetString(objPtr); - Tcl_SetVar(interp, (const char *)name1, objName, 0); + Tcl_SetVar2(interp, name1, NULL, objName, 0); Tcl_DecrRefCount(objPtr); return NULL; @@ -2449,7 +2336,7 @@ * Handle write traces on "selfns" */ if ((flags & TCL_TRACE_WRITES) != 0) { - return "variable \"selfns\" cannot be modified"; + return (char *)"variable \"selfns\" cannot be modified"; } return NULL; } @@ -2494,7 +2381,7 @@ if ((flags & TCL_TRACE_READS) != 0) { return NULL; } - + /* * Handle write traces "itcl_options" */ @@ -2556,13 +2443,13 @@ } /* need to redo the delegation for this component !! */ if (hPtr == NULL) { - return " INTERNAL ERROR cannot get component to write to"; + return (char *)" INTERNAL ERROR cannot get component to write to"; } - icPtr = Tcl_GetHashValue(hPtr); + icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); val = ItclGetInstanceVar(interp, name1, NULL, ioPtr, ioPtr->iclsPtr); if ((val == NULL) || (strlen(val) == 0)) { - return " INTERNAL ERROR cannot get value for component"; + return (char *)" INTERNAL ERROR cannot get value for component"; } componentValuePtr = Tcl_NewStringObj(val, -1); Tcl_IncrRefCount(componentValuePtr); @@ -2590,12 +2477,12 @@ } else { icPtr = (ItclComponent *)cdata; /* - * Handle read traces + * Handle read traces */ if ((flags & TCL_TRACE_READS) != 0) { return NULL; } - + /* * Handle write traces */ @@ -2645,9 +2532,9 @@ hPtr = Tcl_FindHashEntry(&ioPtr->iclsPtr->variables, (char *)objPtr); Tcl_DecrRefCount(objPtr); if (hPtr == NULL) { - return "INTERNAL ERROR cannot find itcl_hull variable in class definition!!"; + return (char *)"INTERNAL ERROR cannot find itcl_hull variable in class definition!!"; } - ivPtr = Tcl_GetHashValue(hPtr); + ivPtr = (ItclVariable *)Tcl_GetHashValue(hPtr); /* * Handle write traces */ @@ -2656,19 +2543,19 @@ ivPtr->initted = 1; return NULL; } else { - return "The itcl_hull component cannot be redefined"; + return (char *)"The itcl_hull component cannot be redefined"; } } } else { ivPtr = (ItclVariable *)cdata; /* - * Handle read traces + * Handle read traces */ if ((flags & TCL_TRACE_READS) != 0) { return NULL; } - + /* * Handle write traces */ @@ -2732,20 +2619,19 @@ } 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 - * by ItclReleaseObject(), when an object's data is no longer being used. + * the given object instance. Called when releases match preserves. * ------------------------------------------------------------------------ */ static void -ItclFreeObject( +FreeObject( char * cdata) /* object instance data */ { FOREACH_HASH_DECLS; @@ -2753,7 +2639,7 @@ ItclCallContext *callContextPtr; ItclObject *ioPtr; Tcl_Var var; - + ioPtr = (ItclObject*)cdata; /* @@ -2782,13 +2668,13 @@ * Delete all context definitions. */ while (1) { - hPtr = Tcl_FirstHashEntry(&ioPtr->contextCache, &place); - if (hPtr == NULL) { - break; - } - callContextPtr = Tcl_GetHashValue(hPtr); + hPtr = Tcl_FirstHashEntry(&ioPtr->contextCache, &place); + if (hPtr == NULL) { + break; + } + callContextPtr = (ItclCallContext *)Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); - ckfree((char *)callContextPtr); + ckfree((char *)callContextPtr); } FOREACH_HASH_VALUE(var, &ioPtr->objectVariables) { Itcl_ReleaseVar(var); @@ -2814,7 +2700,7 @@ ckfree((char *)ioPtr->resolvePtr->clientData); ckfree((char*)ioPtr->resolvePtr); } - ckfree((char*)ioPtr); + Itcl_Free(ioPtr); } /* @@ -2830,9 +2716,9 @@ Tcl_Interp *interp, int result) { - Tcl_Object *oPtr = data[0]; - Tcl_Class clsPtr = data[1]; - Tcl_Obj *const* objv = data[3]; + Tcl_Object *oPtr = (Tcl_Object *)data[0]; + Tcl_Class clsPtr = (Tcl_Class)data[1]; + Tcl_Obj *const *objv = (Tcl_Obj *const *)data[3]; int objc = PTR2INT(data[2]); ItclShowArgs(1, "CallPublicObjectCmd", objc, objv); @@ -3008,7 +2894,7 @@ } else { ItclShowArgs(1, "run CallPublicObjectCmd2", objc, objv); Tcl_NRAddCallback(interp, CallPublicObjectCmd, oPtr, clsPtr, - INT2PTR(objc), (ClientData)objv); + INT2PTR(objc), (void *)objv); } result = Itcl_NRRunCallbacks(interp, callbackPtr); @@ -3084,7 +2970,7 @@ Tcl_IncrRefCount(objPtr); hPtr = Tcl_FindHashEntry(&infoPtr->nameClasses, (char *)objPtr); if (hPtr != NULL) { - iclsPtr = Tcl_GetHashValue(hPtr); + iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); } else { iclsPtr = NULL; } @@ -3205,13 +3091,13 @@ ItclMemberFunc *imPtr2 = NULL; Tcl_HashEntry *hPtr; Tcl_ObjectContext context; - context = Itcl_GetCallFrameClientData(interp); + context = (Tcl_ObjectContext)Itcl_GetCallFrameClientData(interp); if (context != NULL) { hPtr = Tcl_FindHashEntry( &imPtr->iclsPtr->infoPtr->procMethods, (char *)Tcl_ObjectContextMethod(context)); if (hPtr != NULL) { - imPtr2 = Tcl_GetHashValue(hPtr); + imPtr2 = (ItclMemberFunc *)Tcl_GetHashValue(hPtr); } if ((imPtr->protection & ITCL_PRIVATE) && (imPtr2 != NULL) && @@ -3234,7 +3120,7 @@ objPtr = Tcl_NewStringObj(token, -1); hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr); if (hPtr != NULL) { - clookupPtr = Tcl_GetHashValue(hPtr); + clookupPtr = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); imPtr2 = clookupPtr->imPtr; } if ((imPtr->protection & ITCL_PRIVATE) && @@ -3249,7 +3135,7 @@ } else { Tcl_AppendResult(interp, "bad option \"", token, "\": should be one of...", - (char*)NULL); + NULL); ItclReportObjectUsage(interp, ioPtr, nsPtr, nsPtr); return TCL_ERROR; @@ -3580,7 +3466,7 @@ if (hPtr2 == NULL) { ioptPtr = NULL; } else { - ioptPtr = Tcl_GetHashValue(hPtr2); + ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr2); ioptPtr->idoPtr = idoPtr; } idoPtr->ioptPtr = ioptPtr; @@ -3610,7 +3496,7 @@ ItclVariable *ivPtr; const char *val; - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, (char *)varName); + hPtr = ItclResolveVarEntry(iclsPtr, (char *)varName); if (hPtr == NULL) { /* no such variable */ return NULL; @@ -3841,5 +3727,5 @@ if (hPtr == NULL) { return NULL; } - return Tcl_GetHashValue(hPtr); + return (ItclClass *)Tcl_GetHashValue(hPtr); } diff -Nru itcl4-4.1.2/generic/itclParse.c itcl4-4.2.0/generic/itclParse.c --- itcl4-4.1.2/generic/itclParse.c 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/generic/itclParse.c 2019-11-05 14:34:35.000000000 +0000 @@ -198,15 +198,15 @@ * definitions. */ parserNs = Tcl_CreateNamespace(interp, "::itcl::parser", - (ClientData)infoPtr, Itcl_ReleaseData); + infoPtr, Itcl_ReleaseData); if (!parserNs) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " (cannot initialize itcl parser)", - (char*)NULL); + NULL); return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); /* * Add commands for parsing class definitions. @@ -216,7 +216,7 @@ Tcl_DStringAppend(&buffer, "::itcl::parser::", 16); Tcl_DStringAppend(&buffer, parseCmds[i].name, -1); Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), - parseCmds[i].objProc, (ClientData) infoPtr, NULL); + parseCmds[i].objProc, infoPtr, NULL); Tcl_DStringFree(&buffer); } @@ -227,7 +227,7 @@ pInfoPtr->pLevel = protectionCmds[i].protection; pInfoPtr->infoPtr = infoPtr; Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), - protectionCmds[i].objProc, (ClientData) pInfoPtr, + protectionCmds[i].objProc, pInfoPtr, (Tcl_CmdDeleteProc*) ItclFreeParserCommandData); Tcl_DStringFree(&buffer); } @@ -244,16 +244,16 @@ * Install the "class" command for defining new classes. */ Tcl_CreateObjCommand(interp, "::itcl::class", Itcl_ClassCmd, - (ClientData)infoPtr, Itcl_ReleaseData); - Itcl_PreserveData((ClientData)infoPtr); + infoPtr, Itcl_ReleaseData); + Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::body", Itcl_BodyCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "::itcl::configbody", Itcl_ConfigBodyCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + NULL, NULL); - Itcl_EventuallyFree((ClientData)infoPtr, ItclDelObjectInfo); + Itcl_EventuallyFree(infoPtr, (Tcl_FreeProc *) ItclDelObjectInfo); /* * Create the "itcl::find" command for high-level queries. @@ -265,18 +265,18 @@ if (Itcl_AddEnsemblePart(interp, "::itcl::find", "classes", "?pattern?", Itcl_FindClassesCmd, - (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::find", "objects", "?-class className? ?-isa className? ?pattern?", Itcl_FindObjectsCmd, - (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); /* @@ -290,26 +290,26 @@ if (Itcl_AddEnsemblePart(interp, "::itcl::delete", "class", "name ?name...?", Itcl_DelClassCmd, - (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::delete", "object", "name ?name...?", Itcl_DelObjectCmd, - (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::delete", "ensemble", "name ?name...?", Itcl_EnsembleDeleteCmd, - (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); /* * Create the "itcl::is" command to test object @@ -321,27 +321,27 @@ if (Itcl_AddEnsemblePart(interp, "::itcl::is", "class", "name", Itcl_IsClassCmd, - (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::is", "object", "?-class classname? name", Itcl_IsObjectCmd, - (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); /* * Add "code" and "scope" commands for handling scoped values. */ Tcl_CreateObjCommand(interp, "::itcl::code", Itcl_CodeCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "::itcl::scope", Itcl_ScopeCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + NULL, NULL); /* * Add the "filter" commands (add/delete) @@ -351,18 +351,18 @@ } if (Itcl_AddEnsemblePart(interp, "::itcl::filter", "add", "objectOrClass filter ? ... ?", Itcl_FilterAddCmd, - (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::filter", "delete", "objectOrClass filter ? ... ?", Itcl_FilterDeleteCmd, - (ClientData)infoPtr, Itcl_ReleaseData) != TCL_OK) { + infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); /* * Add the "forward" commands (add/delete) @@ -373,19 +373,19 @@ if (Itcl_AddEnsemblePart(interp, "::itcl::forward", "add", "objectOrClass srcCommand targetCommand ? options ... ?", - Itcl_ForwardAddCmd, (ClientData)infoPtr, + Itcl_ForwardAddCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::forward", "delete", "objectOrClass targetCommand ? ... ?", - Itcl_ForwardDeleteCmd, (ClientData)infoPtr, + Itcl_ForwardDeleteCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); /* * Add the "mixin" (add/delete) commands. @@ -396,19 +396,19 @@ if (Itcl_AddEnsemblePart(interp, "::itcl::mixin", "add", "objectOrClass class ? class ... ?", - Itcl_MixinAddCmd, (ClientData)infoPtr, + Itcl_MixinAddCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::mixin", "delete", "objectOrClass class ? class ... ?", - Itcl_MixinDeleteCmd, (ClientData)infoPtr, + Itcl_MixinDeleteCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); /* * Add commands for handling import stubs at the Tcl level. @@ -419,65 +419,65 @@ if (Itcl_AddEnsemblePart(interp, "::itcl::import::stub", "create", "name", Itcl_StubCreateCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) { + NULL, NULL) != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::import::stub", "exists", "name", Itcl_StubExistsCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) { + NULL, NULL) != TCL_OK) { return TCL_ERROR; } Tcl_CreateObjCommand(interp, "::itcl::type", Itcl_TypeClassCmd, - (ClientData)infoPtr, Itcl_ReleaseData); - Itcl_PreserveData((ClientData)infoPtr); + infoPtr, Itcl_ReleaseData); + Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::widget", Itcl_WidgetCmd, - (ClientData)infoPtr, Itcl_ReleaseData); - Itcl_PreserveData((ClientData)infoPtr); + infoPtr, Itcl_ReleaseData); + Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::widgetadaptor", Itcl_WidgetAdaptorCmd, - (ClientData)infoPtr, Itcl_ReleaseData); - Itcl_PreserveData((ClientData)infoPtr); + infoPtr, Itcl_ReleaseData); + Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::nwidget", Itcl_NWidgetCmd, - (ClientData)infoPtr, Itcl_ReleaseData); - Itcl_PreserveData((ClientData)infoPtr); + infoPtr, Itcl_ReleaseData); + Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::addoption", Itcl_AddOptionCmd, - (ClientData)infoPtr, Itcl_ReleaseData); - Itcl_PreserveData((ClientData)infoPtr); + infoPtr, Itcl_ReleaseData); + Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::addobjectoption", Itcl_AddObjectOptionCmd, - (ClientData)infoPtr, Itcl_ReleaseData); - Itcl_PreserveData((ClientData)infoPtr); + infoPtr, Itcl_ReleaseData); + Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::adddelegatedoption", Itcl_AddDelegatedOptionCmd, - (ClientData)infoPtr, Itcl_ReleaseData); - Itcl_PreserveData((ClientData)infoPtr); + infoPtr, Itcl_ReleaseData); + Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::adddelegatedmethod", Itcl_AddDelegatedFunctionCmd, - (ClientData)infoPtr, Itcl_ReleaseData); - Itcl_PreserveData((ClientData)infoPtr); + infoPtr, Itcl_ReleaseData); + Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::addcomponent", Itcl_AddComponentCmd, - (ClientData)infoPtr, Itcl_ReleaseData); - Itcl_PreserveData((ClientData)infoPtr); + infoPtr, Itcl_ReleaseData); + Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::setcomponent", Itcl_SetComponentCmd, - (ClientData)infoPtr, Itcl_ReleaseData); - Itcl_PreserveData((ClientData)infoPtr); + infoPtr, Itcl_ReleaseData); + Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::extendedclass", Itcl_ExtendedClassCmd, - (ClientData)infoPtr, Itcl_ReleaseData); - Itcl_PreserveData((ClientData)infoPtr); + infoPtr, Itcl_ReleaseData); + Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, ITCL_COMMANDS_NAMESPACE "::genericclass", - ItclGenericClassCmd, (ClientData)infoPtr, Itcl_ReleaseData); - Itcl_PreserveData((ClientData)infoPtr); + ItclGenericClassCmd, infoPtr, Itcl_ReleaseData); + Itcl_PreserveData(infoPtr); /* * Add the "delegate" (method/option) commands. @@ -488,27 +488,27 @@ if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate", "method", "name to targetName as scipt using script", - Itcl_ClassDelegateMethodCmd, (ClientData)infoPtr, + Itcl_ClassDelegateMethodCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate", "typemethod", "name to targetName as scipt using script", - Itcl_ClassDelegateTypeMethodCmd, (ClientData)infoPtr, + Itcl_ClassDelegateTypeMethodCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate", "option", "option to targetOption as script", - Itcl_ClassDelegateOptionCmd, (ClientData)infoPtr, + Itcl_ClassDelegateOptionCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } - Itcl_PreserveData((ClientData)infoPtr); + Itcl_PreserveData(infoPtr); return TCL_OK; } @@ -582,7 +582,6 @@ return TCL_ERROR; } iclsPtr->numVariables++; - Itcl_BuildVirtualTables(iclsPtr); } Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_GetString(iclsPtr->fullNamePtr), NULL); @@ -621,10 +620,7 @@ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { - ItclClass *iclsPtr; - - return ItclClassBaseCmd(clientData, interp, ITCL_CLASS, objc, objv, - &iclsPtr); + return ItclClassBaseCmd(clientData, interp, ITCL_CLASS, objc, objv, NULL); } /* @@ -642,7 +638,7 @@ TCL_OO_METHOD_VERSION_CURRENT, "itcl objv method", ObjCallProc, - ItclReleaseIMF, + Itcl_ReleaseData, CloneProc }; @@ -650,7 +646,7 @@ TCL_OO_METHOD_VERSION_CURRENT, "itcl argv method", ArgCallProc, - ItclReleaseIMF, + Itcl_ReleaseData, CloneProc }; @@ -660,7 +656,7 @@ ClientData original, ClientData *copyPtr) { - ItclPreserveIMF((ItclMemberFunc *)original); + Itcl_PreserveData((ItclMemberFunc *)original); *copyPtr = original; return TCL_OK; } @@ -672,7 +668,7 @@ int result) { ClientData clientData = data[0]; - Tcl_ObjectContext context = data[1]; + Tcl_ObjectContext context = (Tcl_ObjectContext)data[1]; return ItclAfterCallMethod(clientData, interp, context, NULL, result); } @@ -755,7 +751,7 @@ * If for some reason it is destroyed, bail out here. */ parserNs = Tcl_FindNamespace(interp, "::itcl::parser", - (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); + NULL, TCL_LEAVE_ERR_MSG); if (parserNs == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( @@ -802,7 +798,7 @@ * becomes the current context for all commands in the parser. * Activate the parser and evaluate the class definition. */ - Itcl_PushStack((ClientData)iclsPtr, &infoPtr->clsStack); + Itcl_PushStack(iclsPtr, &infoPtr->clsStack); result = Itcl_PushCallFrame(interp, &frame, parserNs, /* isProcCallFrame */ 0); @@ -833,6 +829,7 @@ "\n (class \"%s\" body line %s)", className, Tcl_GetString(stackTrace))); } + Tcl_DecrRefCount(options); result = TCL_ERROR; goto errorReturn; } @@ -850,7 +847,7 @@ Tcl_NewStringObj("::itcl::Root", -1)); Tcl_IncrRefCount(cmdPtr); - result = Tcl_EvalObj(interp, cmdPtr); + result = Tcl_EvalObjEx(interp, cmdPtr, 0); Tcl_DecrRefCount(cmdPtr); if (result == TCL_ERROR) { goto errorReturn; @@ -882,22 +879,22 @@ /* Implementation of this member is coded in C expecting Tcl_Obj */ imPtr->tmPtr = Tcl_NewMethod(interp, iclsPtr->clsPtr, imPtr->namePtr, - 1, &itclObjMethodType, (ClientData) imPtr); - ItclPreserveIMF(imPtr); + 1, &itclObjMethodType, imPtr); + Itcl_PreserveData(imPtr); if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { imPtr->tmPtr = Tcl_NewInstanceMethod(interp, iclsPtr->oPtr, - imPtr->namePtr, 1, &itclObjMethodType, (ClientData) imPtr); - ItclPreserveIMF(imPtr); + imPtr->namePtr, 1, &itclObjMethodType, 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, (ClientData) imPtr); + 1, &itclArgMethodType, imPtr); - ItclPreserveIMF(imPtr); + Itcl_PreserveData(imPtr); @@ -1059,7 +1056,7 @@ } Tcl_AppendToObj(bodyPtr, " {*}$args]", -1); } - imPtr->tmPtr = (ClientData)Itcl_NewProcClassMethod(interp, + imPtr->tmPtr = Itcl_NewProcClassMethod(interp, iclsPtr->clsPtr, ItclCheckCallMethod, ItclAfterCallMethod, ItclProcErrorProc, imPtr, imPtr->namePtr, argumentPtr, bodyPtr, &pmPtr); @@ -1081,7 +1078,7 @@ if (isNewEntry) { Tcl_DeleteHashEntry(hPtr2); } - imPtr->tmPtr = (ClientData)Itcl_NewProcMethod(interp, + imPtr->tmPtr = Itcl_NewProcMethod(interp, iclsPtr->oPtr, ItclCheckCallMethod, ItclAfterCallMethod, ItclProcErrorProc, imPtr, imPtr->namePtr, argumentPtr, bodyPtr, &pmPtr); @@ -1090,13 +1087,13 @@ 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)) { @@ -1329,7 +1326,7 @@ while (elem) { cdPtr = (ItclClass*)Itcl_GetListValue(elem); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - Tcl_GetString(cdPtr->namePtr), " ", (char*)NULL); + Tcl_GetString(cdPtr->namePtr), " ", NULL); elem = Itcl_NextListElem(elem); } @@ -1337,7 +1334,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\" already defined for class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -1371,11 +1368,11 @@ Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot inherit from \"", token, "\"", - (char*)NULL); + NULL); if (errlen > 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - " (", errmsg, ")", (char*)NULL); + " (", errmsg, ")", NULL); } Tcl_DecrRefCount(resultPtr); goto inheritError; @@ -1389,11 +1386,11 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "class \"", Tcl_GetString(iclsPtr->namePtr), "\" cannot inherit from itself", - (char*)NULL); + NULL); goto inheritError; } - Itcl_AppendList(&iclsPtr->bases, (ClientData)baseClsPtr); + Itcl_AppendList(&iclsPtr->bases, baseClsPtr); ItclPreserveClass(baseClsPtr); } @@ -1411,7 +1408,7 @@ "class \"", iclsPtr->fullNamePtr, "\" cannot inherit base class \"", cdPtr->fullNamePtr, "\" more than once", - (char*)NULL); + NULL); goto inheritError; } elem2 = Itcl_NextListElem(elem2); @@ -1451,11 +1448,11 @@ "class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\" inherits base class \"", Tcl_GetString(badCdPtr->fullNamePtr), "\" more than once:", - (char*)NULL); + NULL); cdPtr = iclsPtr; Itcl_InitStack(&stack); - Itcl_PushStack((ClientData)cdPtr, &stack); + Itcl_PushStack(cdPtr, &stack); /* * Show paths leading to bad base class @@ -1470,7 +1467,7 @@ cdPtr = (ItclClass*)Itcl_GetStackValue(&stack, i-1); Tcl_AppendStringsToObj(resultPtr, Tcl_GetString(cdPtr->namePtr), "->", - (char*)NULL); + NULL); } } Tcl_AppendToObj(resultPtr, @@ -1482,8 +1479,8 @@ else { elem = Itcl_LastListElem(&cdPtr->bases); if (elem) { - Itcl_PushStack((ClientData)cdPtr, &stack); - Itcl_PushStack((ClientData)NULL, &stack); + Itcl_PushStack(cdPtr, &stack); + Itcl_PushStack(NULL, &stack); while (elem) { Itcl_PushStack(Itcl_GetListValue(elem), &stack); elem = Itcl_PrevListElem(elem); @@ -1513,7 +1510,7 @@ Tcl_DStringAppend(&buffer, " ", -1); Tcl_DStringAppend(&buffer, Tcl_GetString(baseClsPtr->fullNamePtr), -1); - Itcl_AppendList(&baseClsPtr->derived, (ClientData)iclsPtr); + Itcl_AppendList(&baseClsPtr->derived, iclsPtr); ItclPreserveClass(iclsPtr); elem = Itcl_NextListElem(elem); @@ -1591,21 +1588,16 @@ } else { /* something like: public variable a 123 456 */ result = Itcl_EvalArgs(interp, objc-1, objv+1); - if (result == TCL_ERROR) { - Tcl_ResetResult(interp); - Tcl_WrongNumArgs(interp, 1, objv, "command ?arg arg...? or wrong command name"); - return TCL_ERROR; - } } if (result == TCL_BREAK) { - Tcl_SetResult(interp, "invoked \"break\" outside of a loop", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("invoked \"break\" outside of a loop", + -1)); result = TCL_ERROR; } else { if (result == TCL_CONTINUE) { - Tcl_SetResult(interp, "invoked \"continue\" outside of a loop", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("invoked \"continue\" outside of a loop", + -1)); result = TCL_ERROR; } else { if (result != TCL_OK) { @@ -1677,7 +1669,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", Tcl_GetString(namePtr), "\" already defined in class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -1744,11 +1736,11 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", Tcl_GetString(namePtr), "\" already defined in class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } - if (Itcl_CreateMethod(interp, iclsPtr, namePtr, (char*)NULL, body) + if (Itcl_CreateMethod(interp, iclsPtr, namePtr, NULL, body) != TCL_OK) { return TCL_ERROR; } @@ -1960,7 +1952,7 @@ } iclsPtr->infoPtr->functionFlags = 0; hPtr = Tcl_FindHashEntry(&iclsPtr->functions, (char *)namePtr); - imPtr = Tcl_GetHashValue(hPtr); + imPtr = (ItclMemberFunc *)Tcl_GetHashValue(hPtr); imPtr->flags |= ITCL_TYPE_METHOD; return TCL_OK; } @@ -2048,7 +2040,7 @@ if (strstr(Tcl_GetString(namePtr), "::")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad variable name \"", Tcl_GetString(namePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -2143,50 +2135,43 @@ Itcl_PopCallFrame(interp); /* - * TRICKY NOTE: Make sure to rebuild the virtual tables for this - * class so that this variable is ready to access. The variable - * resolver for the parser namespace needs this info to find the - * variable if the developer tries to set it within the class - * definition. - * * If an initialization value was specified, then initialize - * the variable now. + * the variable now, otherwise be sure the variable is uninitialized. */ - Itcl_BuildVirtualTables(iclsPtr); if (initStr != NULL) { const char *val; - Tcl_DStringAppend(&buffer, "::", -1); - Tcl_DStringAppend(&buffer, Tcl_GetString(ivPtr->namePtr), -1); - val = Tcl_SetVar(interp, - Tcl_DStringValue(&buffer), initStr, - TCL_NAMESPACE_ONLY); - + val = Tcl_SetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), NULL, + initStr, TCL_NAMESPACE_ONLY); if (!val) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot initialize common variable \"", Tcl_GetString(ivPtr->namePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } + } else { + /* previous var-lookup in class body (in ::itcl::parser) could obtain + * inherited common vars, so be sure it does not exists after new + * common creation (simply remove this reference). */ + Tcl_UnsetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), NULL, + TCL_NAMESPACE_ONLY); } if (ivPtr->arrayInitPtr != NULL) { int i; int argc; const char **argv; const char *val; - Tcl_DStringAppend(&buffer, "::", -1); - Tcl_DStringAppend(&buffer, Tcl_GetString(ivPtr->namePtr), -1); result = Tcl_SplitList(interp, Tcl_GetString(ivPtr->arrayInitPtr), &argc, &argv); for (i = 0; i < argc; i++) { - val = Tcl_SetVar2(interp, Tcl_DStringValue(&buffer), argv[i], + val = Tcl_SetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), argv[i], argv[i + 1], TCL_NAMESPACE_ONLY); if (!val) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot initialize common variable \"", Tcl_GetString(ivPtr->namePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } i++; @@ -2272,7 +2257,7 @@ if (strstr(Tcl_GetString(namePtr), "::")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad variable name \"", Tcl_GetString(namePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -2283,7 +2268,7 @@ } } - if (Itcl_CreateVariable(interp, iclsPtr, namePtr, initStr, (char*)NULL, + if (Itcl_CreateVariable(interp, iclsPtr, namePtr, initStr, NULL, &ivPtr) != TCL_OK) { return TCL_ERROR; } @@ -2385,6 +2370,8 @@ * Invoked when the management info for [incr Tcl] is no longer being * used in an interpreter. This will only occur when all class * manipulation commands are removed from the interpreter. + * + * See also FreeItclObjectInfo() in itclBase.c * ------------------------------------------------------------------------ */ static void @@ -2415,12 +2402,10 @@ /*hPtr = Tcl_NextHashEntry(&place);*/ } Tcl_DeleteHashTable(&infoPtr->objects); + Tcl_DeleteHashTable(&infoPtr->frameContext); Itcl_DeleteStack(&infoPtr->clsStack); -/* FIXME !!! - free class_meta_type and object_meta_type -*/ - ckfree((char*)infoPtr); + Itcl_Free(infoPtr); } /* @@ -2794,14 +2779,14 @@ if (strstr(name, "::")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option name \"", name, - "\", option names must not contain \"::\"", (char*)NULL); + "\", option names must not contain \"::\"", NULL); result = TCL_ERROR; goto errorOut; } if (strstr(name, " ")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option name \"", name, - "\", option names must not contain \" \"", (char*)NULL); + "\", option names must not contain \" \"", NULL); result = TCL_ERROR; goto errorOut; } @@ -2833,8 +2818,7 @@ init = Tcl_GetString(newObjv[1]); } - ioptPtr = (ItclOption*)ckalloc(sizeof(ItclOption)); - memset(ioptPtr, 0, sizeof(ItclOption)); + ioptPtr = (ItclOption*)Itcl_Alloc(sizeof(ItclOption)); ioptPtr->protection = Itcl_Protection(interp, 0); if (ioptPtr->protection == ITCL_DEFAULT_PROTECT) { ioptPtr->protection = ITCL_PROTECTED; @@ -2931,9 +2915,9 @@ if ((objc > 1) && (strcmp(Tcl_GetString(objv[1]), "add") == 0)) { tkVersion = "8.6"; - tkPackage = Tcl_PkgPresent(interp, "Tk", tkVersion, 0); + tkPackage = Tcl_PkgPresentEx(interp, "Tk", tkVersion, 0, NULL); if (tkPackage == NULL) { - tkPackage = Tcl_PkgRequire(interp, "Tk", tkVersion, 0); + tkPackage = Tcl_PkgRequireEx(interp, "Tk", tkVersion, 0, NULL); } if (tkPackage == NULL) { Tcl_AppendResult(interp, "cannot load package Tk", tkVersion, @@ -3007,7 +2991,7 @@ Tcl_SetHashValue(hPtr, icPtr); ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr); } else { - icPtr =Tcl_GetHashValue(hPtr); + icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); } *icPtrPtr = icPtr; return TCL_OK; @@ -3038,7 +3022,7 @@ ItclClass *iclsPtr; ItclComponent *icPtr; const char *usage; - const char *public; + const char *publ; int inherit; int haveInherit; int havePublic; @@ -3072,7 +3056,7 @@ } inherit = 0; haveInherit = 0; - public = NULL; + publ = NULL; havePublic = 0; for (i = 2; i < objc; i++) { if (strcmp(Tcl_GetString(objv[i]), "-inherit") == 0) { @@ -3116,7 +3100,7 @@ usage, NULL); return TCL_ERROR; } - public = Tcl_GetString(objv[i + 1]); + publ = Tcl_GetString(objv[i + 1]); } else { Tcl_AppendResult(interp, "wrong syntax should be: ", usage, NULL); @@ -3160,13 +3144,13 @@ Tcl_DecrRefCount(newObjv[3]); ckfree((char *)newObjv); } - if (public != NULL) { + if (publ != NULL) { icPtr->flags |= ITCL_COMPONENT_PUBLIC; newObjc = 4; newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*)*newObjc); newObjv[0] = Tcl_NewStringObj("delegate::method", -1); Tcl_IncrRefCount(newObjv[0]); - newObjv[1] = Tcl_NewStringObj(public, -1); + newObjv[1] = Tcl_NewStringObj(publ, -1); Tcl_IncrRefCount(newObjv[1]); newObjv[2] = Tcl_NewStringObj("to", -1); Tcl_IncrRefCount(newObjv[2]); @@ -3455,7 +3439,7 @@ } } if (hPtr != NULL) { - icPtr = Tcl_GetHashValue(hPtr); + icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); } if (*methodName != '*') { /* FIXME !!! */ @@ -3627,14 +3611,14 @@ if (strstr(option, "::")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option name \"", option, - "\", option names must not contain \"::\"", (char*)NULL); + "\", option names must not contain \"::\"", NULL); ckfree((char *)argv); return TCL_ERROR; } if (strstr(option, " ")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option name \"", option, - "\", option names must not contain \" \"", (char*)NULL); + "\", option names must not contain \" \"", NULL); ckfree((char *)argv); return TCL_ERROR; } @@ -3749,7 +3733,7 @@ } } if (hPtr != NULL) { - icPtr = Tcl_GetHashValue(hPtr); + icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); } if (*option != '*') { /* FIXME !!! */ @@ -3774,8 +3758,7 @@ 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) { @@ -3799,7 +3782,7 @@ idoPtr->namePtr = optionNamePtr; } Itcl_PreserveData(idoPtr); - Itcl_EventuallyFree((ClientData)idoPtr, ItclDeleteDelegatedOption); + Itcl_EventuallyFree(idoPtr, (Tcl_FreeProc *) ItclDeleteDelegatedOption); idoPtr->icPtr = icPtr; idoPtr->asPtr = targetPtr; if (idoPtr->asPtr != NULL) { @@ -3826,7 +3809,7 @@ 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) { @@ -4019,7 +4002,7 @@ return TCL_ERROR; } } else { - icPtr = Tcl_GetHashValue(hPtr); + icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); } } else { icPtr = NULL; @@ -4197,7 +4180,7 @@ if (strstr(Tcl_GetString(namePtr), "::")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad variable name \"", Tcl_GetString(namePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } @@ -4235,7 +4218,7 @@ return TCL_ERROR; } iclsPtr->numVariables++; - result = Itcl_CreateMethodVariable(interp, iclsPtr, namePtr, defaultPtr, + result = ItclCreateMethodVariable(interp, ivPtr, defaultPtr, callbackPtr, &imvPtr); if (result != TCL_OK) { return result; @@ -4300,7 +4283,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", Tcl_GetString(namePtr), "\" already defined in class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", - (char*)NULL); + NULL); return TCL_ERROR; } diff -Nru itcl4-4.1.2/generic/itclResolve2.c itcl4-4.2.0/generic/itclResolve2.c --- itcl4-4.1.2/generic/itclResolve2.c 2015-07-08 11:54:41.000000000 +0000 +++ itcl4-4.2.0/generic/itclResolve2.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,564 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * PACKAGE: [incr Tcl] - * DESCRIPTION: Object-Oriented Extensions to Tcl - * - * These procedures handle command and variable resolution - * - * ======================================================================== - * AUTHOR: Arnulf Wiedemann - * - * ======================================================================== - * Copyright (c) Arnulf Wiedemann - * ------------------------------------------------------------------------ - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ -#include -#include "itclInt.h" -#include "itclVCInt.h" - -/* - * This structure is a subclass of Tcl_ResolvedVarInfo that contains the - * ItclVarLookup info needed at runtime. - */ -typedef struct ItclResolvedVarInfo { - Tcl_ResolvedVarInfo vinfo; /* This must be the first element. */ - ItclVarLookup *vlookup; /* Pointer to lookup info. */ -} ItclResolvedVarInfo; - -static Tcl_Var ItclClassRuntimeVarResolver2 ( - Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr); - -int -Itcl_CheckClassVariableProtection( - Tcl_Interp *interp, - Tcl_Namespace *nsPtr, - const char *varName, - ClientData clientData) -{ - ItclClassVarInfo *icviPtr; - - icviPtr = (ItclClassVarInfo *)clientData; - if (icviPtr->protection == ITCL_PRIVATE) { - if (icviPtr->declaringNsPtr != nsPtr) { - Tcl_AppendResult(interp, "can't read \"", varName, - "\": no such variable", NULL); - return TCL_ERROR; - } - } - return TCL_OK; -} - -int -Itcl_CheckClassCommandProtection( - Tcl_Interp *interp, - Tcl_Namespace *nsPtr, - const char *commandName, - ClientData clientData) -{ - /* FIXME need code here !!! */ - return TCL_OK; -} - - -/* - * ------------------------------------------------------------------------ - * Itcl_ClassCmdResolver() - * - * Used by the class namespaces to handle name resolution for all - * commands. This procedure looks for references to class methods - * and procs, and returns TCL_OK along with the appropriate Tcl - * command in the rPtr argument. If a particular command is private, - * this procedure returns TCL_ERROR and access to the command is - * denied. If a command is not recognized, this procedure returns - * TCL_CONTINUE, and lookup continues via the normal Tcl name - * resolution rules. - * ------------------------------------------------------------------------ - */ -int -Itcl_ClassCmdResolver2( - Tcl_Interp *interp, /* current interpreter */ - const char* name, /* name of the command being accessed */ - Tcl_Namespace *nsPtr, /* namespace performing the resolution */ - int flags, /* TCL_LEAVE_ERR_MSG => leave error messages - * in interp if anything goes wrong */ - Tcl_Command *rPtr) /* returns: resolved command */ -{ - ItclClass *iclsPtr; - ItclObjectInfo *infoPtr; - ItclObject *contextIoPtr; - - Tcl_Command cmdPtr; - ItclResolvingInfo *iriPtr; - ObjectCmdTableInfo *octiPtr; - ObjectCmdInfo *ociPtr; - Tcl_HashEntry *hPtr; - - if ((name[0] == 't') && (strcmp(name, "this") == 0)) { - return TCL_CONTINUE; - } - infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, - ITCL_INTERP_DATA, NULL); - hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); - if (hPtr == NULL) { - return TCL_CONTINUE; - } - iclsPtr = Tcl_GetHashValue(hPtr); - ItclCallContext *callContextPtr; - callContextPtr = Itcl_PeekStack(&infoPtr->contextStack); - iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); - hPtr = Tcl_FindHashEntry(&iriPtr->resolveCmds , nsPtr->fullName); - if (hPtr != NULL) { - Tcl_HashTable *tablePtr; - tablePtr = Tcl_GetHashValue(hPtr); - hPtr = Tcl_FindHashEntry(tablePtr, name); - if (hPtr != NULL) { - ItclClassCmdInfo *icciPtr = Tcl_GetHashValue(hPtr); - if ((callContextPtr != NULL) && (callContextPtr->ioPtr != NULL)) { - contextIoPtr = callContextPtr->ioPtr; - hPtr = Tcl_FindHashEntry(&iriPtr->objectCmdsTables, - (char *)contextIoPtr); - if (hPtr != NULL) { - octiPtr = Tcl_GetHashValue(hPtr); - hPtr = Tcl_FindHashEntry(&octiPtr->cmdInfos, - (char *)icciPtr); - if (hPtr != NULL) { - int ret; - ociPtr = Tcl_GetHashValue(hPtr); - ret = (* iriPtr->cmdProtFcn)(interp, - Tcl_GetCurrentNamespace(interp), name, - (ClientData)icciPtr); - if (ret != TCL_OK) { - return ret; - } - cmdPtr = ociPtr->cmdPtr; - *rPtr = cmdPtr; - return TCL_OK; - } - } - } - } - } - return TCL_CONTINUE; -} - - -/* - * ------------------------------------------------------------------------ - * Itcl_ClassVarResolver() - * - * Used by the class namespaces to handle name resolution for runtime - * variable accesses. This procedure looks for references to both - * common variables and instance variables at runtime. It is used as - * a second line of defense, to handle references that could not be - * resolved as compiled locals. - * - * If a variable is found, this procedure returns TCL_OK along with - * the appropriate Tcl variable in the rPtr argument. If a particular - * variable is private, this procedure returns TCL_ERROR and access - * to the variable is denied. If a variable is not recognized, this - * procedure returns TCL_CONTINUE, and lookup continues via the normal - * Tcl name resolution rules. - * ------------------------------------------------------------------------ - */ -int -Itcl_ClassVarResolver2( - Tcl_Interp *interp, /* current interpreter */ - const char* name, /* name of the variable being accessed */ - Tcl_Namespace *nsPtr, /* namespace performing the resolution */ - int flags, /* TCL_LEAVE_ERR_MSG => leave error messages - * in interp if anything goes wrong */ - Tcl_Var *rPtr) /* returns: resolved variable */ -{ - ItclObjectInfo *infoPtr; - ItclClass *iclsPtr; - ItclObject *contextIoPtr; - Tcl_HashEntry *hPtr; - ItclVarLookup *vlookup; - - Tcl_Var varPtr; - ItclResolvingInfo *iriPtr; - ObjectVarTableInfo *ovtiPtr; - ObjectVarInfo *oviPtr; - - Tcl_Namespace *upNsPtr; - upNsPtr = Itcl_GetUplevelNamespace(interp, 1); - - /* - * If this is a global variable, handle it in the usual - * Tcl manner. - */ - if (flags & TCL_GLOBAL_ONLY) { - return TCL_CONTINUE; - } - - infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, - ITCL_INTERP_DATA, NULL); - hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); - if (hPtr == NULL) { - return TCL_CONTINUE; - } - iclsPtr = Tcl_GetHashValue(hPtr); - - /* - * See if this is a formal parameter in the current proc scope. - * If so, that variable has precedence. Look it up and return - * it here. This duplicates some of the functionality of - * TclLookupVar, but we return it here (instead of returning - * TCL_CONTINUE) to avoid looking it up again later. - */ - ItclCallContext *callContextPtr; - callContextPtr = Itcl_PeekStack(&infoPtr->contextStack); - if ((strstr(name,"::") == NULL) && - Itcl_IsCallFrameArgument(interp, name)) { - return TCL_CONTINUE; - } - - iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); - hPtr = Tcl_FindHashEntry(&iriPtr->resolveVars , nsPtr->fullName); - if (hPtr != NULL) { - Tcl_HashTable *tablePtr; - tablePtr = Tcl_GetHashValue(hPtr); - hPtr = Tcl_FindHashEntry(tablePtr , name); - if (hPtr != NULL) { - int ret; - ItclClassVarInfo *icviPtr = Tcl_GetHashValue(hPtr); - ret = (* iriPtr->varProtFcn)(interp, - Tcl_GetCurrentNamespace(interp), name, - (ClientData)icviPtr); - if (ret != TCL_OK) { - return ret; - } - /* - * If this is an instance variable, then we have to - * find the object context, - */ - - if ((callContextPtr != NULL) && (callContextPtr->ioPtr != NULL)) { - contextIoPtr = callContextPtr->ioPtr; - hPtr = Tcl_FindHashEntry(&iriPtr->objectVarsTables, - (char *)contextIoPtr); - if (hPtr != NULL) { - ovtiPtr = Tcl_GetHashValue(hPtr); - hPtr = Tcl_FindHashEntry(&ovtiPtr->varInfos, - (char *)icviPtr); - if (hPtr != NULL) { - oviPtr = Tcl_GetHashValue(hPtr); - varPtr = oviPtr->varPtr; - *rPtr = varPtr; - return TCL_OK; - } - } - } - } - } - /* - * See if the variable is a known data member and accessible. - */ - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, name); - if (hPtr == NULL) { - return TCL_CONTINUE; - } - - vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); - if (!vlookup->accessible) { - return TCL_CONTINUE; - } - - /* - * If this is a common data member, then its variable - * is easy to find. Return it directly. - */ - if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) { - hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, - (char *)vlookup->ivPtr); - if (hPtr != NULL) { - *rPtr = Tcl_GetHashValue(hPtr); - return TCL_OK; - } - } - - return TCL_CONTINUE; -} - - -/* - * ------------------------------------------------------------------------ - * Itcl_ClassCompiledVarResolver() - * - * Used by the class namespaces to handle name resolution for compile - * time variable accesses. This procedure looks for references to - * both common variables and instance variables at compile time. If - * the variables are found, they are characterized in a generic way - * by their ItclVarLookup record. At runtime, Tcl constructs the - * compiled local variables by calling ItclClassRuntimeVarResolver. - * - * If a variable is found, this procedure returns TCL_OK along with - * information about the variable in the rPtr argument. If a particular - * variable is private, this procedure returns TCL_ERROR and access - * to the variable is denied. If a variable is not recognized, this - * procedure returns TCL_CONTINUE, and lookup continues via the normal - * Tcl name resolution rules. - * ------------------------------------------------------------------------ - */ -int -Itcl_ClassCompiledVarResolver2( - Tcl_Interp *interp, /* current interpreter */ - const char* name, /* name of the variable being accessed */ - int length, /* number of characters in name */ - Tcl_Namespace *nsPtr, /* namespace performing the resolution */ - Tcl_ResolvedVarInfo **rPtr) /* returns: info that makes it possible to - * resolve the variable at runtime */ -{ - ItclClass *iclsPtr; - ItclObjectInfo *infoPtr; - Tcl_HashEntry *hPtr; - ItclVarLookup *vlookup; - char *buffer; - char storage[64]; - - infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, - ITCL_INTERP_DATA, NULL); - hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); - if (hPtr == NULL) { - return TCL_CONTINUE; - } - iclsPtr = Tcl_GetHashValue(hPtr); - /* - * Copy the name to local storage so we can NULL terminate it. - * If the name is long, allocate extra space for it. - */ - if (length < sizeof(storage)) { - buffer = storage; - } else { - buffer = (char*)ckalloc((unsigned)(length+1)); - } - memcpy((void*)buffer, (void*)name, (size_t)length); - buffer[length] = '\0'; - - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, buffer); - - if (buffer != storage) { - ckfree(buffer); - } - - /* - * If the name is not found, or if it is inaccessible, - * continue on with the normal Tcl name resolution rules. - */ - if (hPtr == NULL) { - return TCL_CONTINUE; - } - - vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); - if (!vlookup->accessible) { - return TCL_CONTINUE; - } - - /* - * Return the ItclVarLookup record. At runtime, Tcl will - * call ItclClassRuntimeVarResolver with this record, to - * plug in the appropriate variable for the current object - * context. - */ - (*rPtr) = (Tcl_ResolvedVarInfo *) ckalloc(sizeof(ItclResolvedVarInfo)); - (*rPtr)->fetchProc = ItclClassRuntimeVarResolver2; - (*rPtr)->deleteProc = NULL; - ((ItclResolvedVarInfo*)(*rPtr))->vlookup = vlookup; - - return TCL_OK; -} - - -/* - * ------------------------------------------------------------------------ - * ItclClassRuntimeVarResolver() - * - * Invoked when Tcl sets up the call frame for an [incr Tcl] method/proc - * at runtime. Resolves data members identified earlier by - * Itcl_ClassCompiledVarResolver. Returns the Tcl_Var representation - * for the data member. - * ------------------------------------------------------------------------ - */ -static Tcl_Var -ItclClassRuntimeVarResolver2( - Tcl_Interp *interp, /* current interpreter */ - Tcl_ResolvedVarInfo *resVarInfo) /* contains ItclVarLookup rep - * for variable */ -{ - ItclVarLookup *vlookup = ((ItclResolvedVarInfo*)resVarInfo)->vlookup; - - ItclClass *iclsPtr; - ItclObject *contextIoPtr; - Tcl_HashEntry *hPtr; - - Tcl_Var varPtr; - ItclResolvingInfo *iriPtr; - ObjectVarTableInfo *ovtiPtr; - ObjectVarInfo *oviPtr; - - /* - * If this is a common data member, then the associated - * variable is known directly. - */ - if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) { - hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, - (char *)vlookup->ivPtr); - if (hPtr != NULL) { - return Tcl_GetHashValue(hPtr); - } - } - iclsPtr = vlookup->ivPtr->iclsPtr; - - /* - * Otherwise, get the current object context and find the - * variable in its data table. - * - * TRICKY NOTE: Get the index for this variable using the - * virtual table for the MOST-SPECIFIC class. - */ - - ItclCallContext *callContextPtr; - - callContextPtr = Itcl_PeekStack(&iclsPtr->infoPtr->contextStack); - if (callContextPtr == NULL) { - return NULL; - } - if (callContextPtr->ioPtr == NULL) { - return NULL; - } - iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); - hPtr = Tcl_FindHashEntry(&iriPtr->resolveVars, - Tcl_GetCurrentNamespace(interp)->fullName); - if (hPtr != NULL) { - Tcl_HashTable *tablePtr; - tablePtr = Tcl_GetHashValue(hPtr); - hPtr = Tcl_FindHashEntry(tablePtr, - Tcl_GetString(vlookup->ivPtr->namePtr)); - if (hPtr != NULL) { - ItclClassVarInfo *icviPtr = Tcl_GetHashValue(hPtr); - int ret; - ret = (* iriPtr->varProtFcn)(interp, - Tcl_GetCurrentNamespace(interp), - Tcl_GetString(vlookup->ivPtr->namePtr), - (ClientData)icviPtr); - if (ret != TCL_OK) { - return NULL; - } - /* - * If this is an instance variable, then we have to - * find the object context, - */ - - contextIoPtr = callContextPtr->ioPtr; - hPtr = Tcl_FindHashEntry(&iriPtr->objectVarsTables, (char *)contextIoPtr); - if (hPtr != NULL) { - ovtiPtr = Tcl_GetHashValue(hPtr); - hPtr = Tcl_FindHashEntry(&ovtiPtr->varInfos, (char *)icviPtr); - if (hPtr != NULL) { - oviPtr = Tcl_GetHashValue(hPtr); - varPtr = oviPtr->varPtr; - return varPtr; - } - } - } - } - return NULL; -} - -/* - * ------------------------------------------------------------------------ - * Itcl_ParseVarResolver() - * - * Used by the "parser" namespace to resolve variable accesses to - * common variables. The runtime resolver procedure is consulted - * whenever a variable is accessed within the namespace. It can - * deny access to certain variables, or perform special lookups itself. - * - * This procedure allows access only to "common" class variables that - * have been declared within the class or inherited from another class. - * A "set" command can be used to initialized common data members within - * the body of the class definition itself: - * - * itcl::class Foo { - * common colors - * set colors(red) #ff0000 - * set colors(green) #00ff00 - * set colors(blue) #0000ff - * ... - * } - * - * itcl::class Bar { - * inherit Foo - * set colors(gray) #a0a0a0 - * set colors(white) #ffffff - * - * common numbers - * set numbers(0) zero - * set numbers(1) one - * } - * - * ------------------------------------------------------------------------ - */ -/* ARGSUSED */ -int -Itcl_ParseVarResolver2( - Tcl_Interp *interp, /* current interpreter */ - const char* name, /* name of the variable being accessed */ - Tcl_Namespace *contextNs, /* namespace context */ - int flags, /* TCL_GLOBAL_ONLY => global variable - * TCL_NAMESPACE_ONLY => namespace variable */ - Tcl_Var* rPtr) /* returns: Tcl_Var for desired variable */ -{ - ItclObjectInfo *infoPtr = (ItclObjectInfo*)contextNs->clientData; - ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); - - Tcl_HashEntry *hPtr; - ItclVarLookup *vlookup; - - /* - * See if the requested variable is a recognized "common" member. - * If it is, make sure that access is allowed. - */ - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, name); - if (hPtr) { - vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); - - if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) { - if (!vlookup->accessible) { - Tcl_AppendResult(interp, - "can't access \"", name, "\": ", - Itcl_ProtectionStr(vlookup->ivPtr->protection), - " variable", - (char*)NULL); - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, - (char *)vlookup->ivPtr); - if (hPtr != NULL) { - *rPtr = Tcl_GetHashValue(hPtr); - return TCL_OK; - } - } - } - - /* - * If the variable is not recognized, return TCL_CONTINUE and - * let lookup continue via the normal name resolution rules. - * This is important for variables like "errorInfo" - * that might get set while the parser namespace is active. - */ - return TCL_CONTINUE; -} - - - -int -ItclSetParserResolver2( - Tcl_Namespace *nsPtr) -{ - Itcl_SetNamespaceResolvers(nsPtr, (Tcl_ResolveCmdProc*)NULL, - Itcl_ParseVarResolver2, (Tcl_ResolveCompiledVarProc*)NULL); - return TCL_OK; -} diff -Nru itcl4-4.1.2/generic/itclResolve.c itcl4-4.2.0/generic/itclResolve.c --- itcl4-4.1.2/generic/itclResolve.c 2017-12-08 13:09:27.000000000 +0000 +++ itcl4-4.2.0/generic/itclResolve.c 2019-11-03 02:24:15.000000000 +0000 @@ -81,7 +81,7 @@ if (hPtr == NULL) { return TCL_CONTINUE; } - iclsPtr = Tcl_GetHashValue(hPtr); + iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); /* * If the command is a member function */ @@ -204,7 +204,7 @@ Tcl_AppendResult(interp, "can't access \"", name, "\": deleted or redefined\n", "(use the \"body\" command to redefine methods/procs)", - (char*)NULL); + NULL); } return TCL_ERROR; /* disallow access! */ } @@ -271,12 +271,12 @@ if (hPtr == NULL) { return TCL_CONTINUE; } - iclsPtr = Tcl_GetHashValue(hPtr); + iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); /* * See if the variable is a known data member and accessible. */ - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, name); + hPtr = ItclResolveVarEntry(iclsPtr, name); if (hPtr == NULL) { return TCL_CONTINUE; } @@ -294,7 +294,7 @@ hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, (char *)vlookup->ivPtr); if (hPtr != NULL) { - *rPtr = Tcl_GetHashValue(hPtr); + *rPtr = (Tcl_Var)Tcl_GetHashValue(hPtr); return TCL_OK; } } @@ -314,7 +314,7 @@ } if (contextIoPtr->iclsPtr != vlookup->ivPtr->iclsPtr) { if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "this") == 0) { - hPtr = Tcl_FindHashEntry(&contextIoPtr->iclsPtr->resolveVars, + hPtr = ItclResolveVarEntry(contextIoPtr->iclsPtr, Tcl_GetString(vlookup->ivPtr->namePtr)); if (hPtr != NULL) { @@ -384,7 +384,7 @@ } } if (hPtr != NULL) { - *rPtr = Tcl_GetHashValue(hPtr); + *rPtr = (Tcl_Var)Tcl_GetHashValue(hPtr); return TCL_OK; } return TCL_CONTINUE; @@ -432,7 +432,7 @@ if (hPtr == NULL) { return TCL_CONTINUE; } - iclsPtr = Tcl_GetHashValue(hPtr); + iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); /* * Copy the name to local storage so we can NULL terminate it. * If the name is long, allocate extra space for it. @@ -445,7 +445,7 @@ memcpy((void*)buffer, (void*)name, (size_t)length); buffer[length] = '\0'; - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, buffer); + hPtr = ItclResolveVarEntry(iclsPtr, buffer); if (buffer != storage) { ckfree(buffer); @@ -508,7 +508,7 @@ hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, (char *)vlookup->ivPtr); if (hPtr != NULL) { - return Tcl_GetHashValue(hPtr); + return (Tcl_Var)Tcl_GetHashValue(hPtr); } } @@ -528,7 +528,7 @@ if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "this") == 0) { /* only for the this variable we need the one of the * contextIoPtr class */ - hPtr = Tcl_FindHashEntry(&contextIoPtr->iclsPtr->resolveVars, + hPtr = ItclResolveVarEntry(contextIoPtr->iclsPtr, Tcl_GetString(vlookup->ivPtr->namePtr)); if (hPtr != NULL) { @@ -654,35 +654,30 @@ * See if the requested variable is a recognized "common" member. * If it is, make sure that access is allowed. */ - hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, name); - if (hPtr) { - vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); - - if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) { - if (!vlookup->accessible) { - Tcl_AppendResult(interp, - "can't access \"", name, "\": ", - Itcl_ProtectionStr(vlookup->ivPtr->protection), - " variable", - (char*)NULL); - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, - (char *)vlookup->ivPtr); - if (hPtr != NULL) { - *rPtr = Tcl_GetHashValue(hPtr); - return TCL_OK; - } - } + hPtr = ItclResolveVarEntry(iclsPtr, name); + if (!hPtr) { + return TCL_CONTINUE; } - /* - * If the variable is not recognized, return TCL_CONTINUE and - * let lookup continue via the normal name resolution rules. - * This is important for variables like "errorInfo" - * that might get set while the parser namespace is active. - */ - return TCL_CONTINUE; + vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); + + if ((vlookup->ivPtr->flags & ITCL_COMMON) == 0) { + return TCL_CONTINUE; + } + if (!vlookup->accessible) { + Tcl_AppendResult(interp, + "can't access \"", name, "\": ", + Itcl_ProtectionStr(vlookup->ivPtr->protection), + " variable", NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, + (char *)vlookup->ivPtr); + if (!hPtr) { + return TCL_CONTINUE; + } + *rPtr = (Tcl_Var)Tcl_GetHashValue(hPtr); + return TCL_OK; } @@ -691,7 +686,7 @@ ItclSetParserResolver( Tcl_Namespace *nsPtr) { - Itcl_SetNamespaceResolvers(nsPtr, (Tcl_ResolveCmdProc*)NULL, - Itcl_ParseVarResolver, (Tcl_ResolveCompiledVarProc*)NULL); + Itcl_SetNamespaceResolvers(nsPtr, NULL, + Itcl_ParseVarResolver, NULL); return TCL_OK; } diff -Nru itcl4-4.1.2/generic/itclStubInit.c itcl4-4.2.0/generic/itclStubInit.c --- itcl4-4.1.2/generic/itclStubInit.c 2017-12-08 13:09:27.000000000 +0000 +++ itcl4-4.2.0/generic/itclStubInit.c 2019-10-04 16:02:02.000000000 +0000 @@ -235,6 +235,8 @@ Itcl_SaveInterpState, /* 23 */ Itcl_RestoreInterpState, /* 24 */ Itcl_DiscardInterpState, /* 25 */ + Itcl_Alloc, /* 26 */ + Itcl_Free, /* 27 */ }; /* !END!: Do not edit above this line. */ diff -Nru itcl4-4.1.2/generic/itclStubLib.c itcl4-4.2.0/generic/itclStubLib.c --- itcl4-4.1.2/generic/itclStubLib.c 2013-11-04 12:54:20.000000000 +0000 +++ itcl4-4.2.0/generic/itclStubLib.c 2019-10-04 16:02:02.000000000 +0000 @@ -42,10 +42,10 @@ const ItclStubs *stubsPtr; const ItclIntStubs *intStubsPtr; const char *actualVersion; - + actualVersion = Tcl_PkgRequireEx(interp, packageName, version, exact, &clientData); - stubsPtr = clientData; + stubsPtr = (const ItclStubs *)clientData; if ((actualVersion == NULL) || (clientData == NULL)) { return NULL; } diff -Nru itcl4-4.1.2/generic/itclStubs.c itcl4-4.2.0/generic/itclStubs.c --- itcl4-4.1.2/generic/itclStubs.c 2016-01-28 17:49:11.000000000 +0000 +++ itcl4-4.2.0/generic/itclStubs.c 2019-10-04 16:02:02.000000000 +0000 @@ -85,7 +85,7 @@ * get the full name of this command later on. */ cmdPtr = Tcl_CreateObjCommand(interp, cmdName, - ItclHandleStubCmd, (ClientData)NULL, + ItclHandleStubCmd, NULL, (Tcl_CmdDeleteProc*)ItclDeleteStub); Tcl_GetCommandInfoFromToken(cmdPtr, &cmdInfo); @@ -126,12 +126,12 @@ } cmdName = Tcl_GetString(objv[1]); - cmdPtr = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace*)NULL, 0); + cmdPtr = Tcl_FindCommand(interp, cmdName, NULL, 0); if ((cmdPtr != NULL) && Itcl_IsStub(cmdPtr)) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 1); } else { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 0); } return TCL_OK; } @@ -169,7 +169,7 @@ ItclShowArgs(1, "ItclHandleStubCmd", objc, objv); cmdPtr = (Tcl_Command) clientData; - cmdNamePtr = Tcl_NewStringObj((char*)NULL, 0); + cmdNamePtr = Tcl_NewStringObj(NULL, 0); Tcl_IncrRefCount(cmdNamePtr); Tcl_GetCommandFullName(interp, cmdPtr, cmdNamePtr); cmdName = Tcl_GetString(cmdNamePtr); @@ -190,7 +190,7 @@ if ((result != TCL_OK) || !loaded) { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "can't autoload \"", cmdName, "\"", (char*)NULL); + "can't autoload \"", cmdName, "\"", NULL); Tcl_DecrRefCount(cmdNamePtr); return TCL_ERROR; } @@ -200,7 +200,7 @@ * Invoke the command again with the arguments passed in. */ cmdlinePtr = Itcl_CreateArgs(interp, cmdName, objc - 1, objv + 1); - (void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr, + (void) Tcl_ListObjGetElements(NULL, cmdlinePtr, &cmdlinec, &cmdlinev); Tcl_DecrRefCount(cmdNamePtr); diff -Nru itcl4-4.1.2/generic/itclTclIntStubsFcn.c itcl4-4.2.0/generic/itclTclIntStubsFcn.c --- itcl4-4.1.2/generic/itclTclIntStubsFcn.c 2016-01-28 17:49:11.000000000 +0000 +++ itcl4-4.2.0/generic/itclTclIntStubsFcn.c 2019-10-04 16:02:02.000000000 +0000 @@ -38,11 +38,11 @@ return code; } -void * +Tcl_ObjCmdProc * _Tcl_GetObjInterpProc( void) { - return (void *)TclGetObjInterpProc(); + return (Tcl_ObjCmdProc *)TclGetObjInterpProc(); } void diff -Nru itcl4-4.1.2/generic/itclTclIntStubsFcn.h itcl4-4.2.0/generic/itclTclIntStubsFcn.h --- itcl4-4.1.2/generic/itclTclIntStubsFcn.h 2013-11-04 12:54:20.000000000 +0000 +++ itcl4-4.2.0/generic/itclTclIntStubsFcn.h 2019-10-04 16:02:02.000000000 +0000 @@ -25,7 +25,7 @@ const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Tcl_Proc *procPtrPtr); MODULE_SCOPE void _Tcl_ProcDeleteProc(ClientData clientData); -MODULE_SCOPE void *_Tcl_GetObjInterpProc(void); +MODULE_SCOPE Tcl_ObjCmdProc *_Tcl_GetObjInterpProc(void); MODULE_SCOPE int Tcl_RenameCommand(Tcl_Interp *interp, const char *oldName, const char *newName); MODULE_SCOPE Tcl_HashTable *Itcl_GetNamespaceChildTable(Tcl_Namespace *nsPtr); diff -Nru itcl4-4.1.2/generic/itclTestRegisterC.c itcl4-4.2.0/generic/itclTestRegisterC.c --- itcl4-4.1.2/generic/itclTestRegisterC.c 2016-06-09 11:50:15.000000000 +0000 +++ itcl4-4.2.0/generic/itclTestRegisterC.c 2019-10-04 16:02:02.000000000 +0000 @@ -60,7 +60,7 @@ Tcl_IncrRefCount(objv[1]); Tcl_IncrRefCount(objv[2]); Tcl_IncrRefCount(objv[3]); - infoPtr = (ClientData)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); FOREACH_HASH_VALUE(classPtr,&infoPtr->nameClasses) { if (strcmp(Tcl_GetString(objv[1]), Tcl_GetString(classPtr->fullNamePtr)) == 0 || strcmp(Tcl_GetString(objv[2]), Tcl_GetString(classPtr->fullNamePtr)) == 0) { @@ -101,7 +101,7 @@ } nsPtr = Tcl_GetCurrentNamespace(interp); fprintf(stderr, "IP:%p %p %p !%s!\n",interp, clientData, nsPtr, nsPtr->fullName); - infoPtr = (ClientData)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); + infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); FOREACH_HASH_VALUE(classPtr,&infoPtr->nameClasses) { if (strcmp(Tcl_GetString(objv[1]), Tcl_GetString(classPtr->fullNamePtr)) == 0 || strcmp(Tcl_GetString(objv[2]), Tcl_GetString(classPtr->fullNamePtr)) == 0) { diff -Nru itcl4-4.1.2/generic/itclUtil.c itcl4-4.2.0/generic/itclUtil.c --- itcl4-4.1.2/generic/itclUtil.c 2017-12-08 13:09:27.000000000 +0000 +++ itcl4-4.2.0/generic/itclUtil.c 2019-10-04 16:02:02.000000000 +0000 @@ -29,10 +29,7 @@ * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "itclInt.h" - -#ifdef ITCL_PRESERVE_DEBUG -#include -#endif +#include /* * POOL OF LIST ELEMENTS FOR LINKED LIST @@ -59,11 +56,6 @@ #define TCL_STATE_VALID 0x01233210 /* magic bit pattern for validation */ -#ifdef ITCL_PRESERVE_DEBUG -static Tcl_HashTable itclPreserveInfos; -static int itclPreserveInfoInitted = 0; -#endif - /* * ------------------------------------------------------------------------ @@ -75,10 +67,10 @@ */ void -Itcl_Assert(testExpr, fileName, lineNumber) - const char *testExpr; /* string representing test expression */ - const char *fileName; /* file name containing this call */ - int lineNumber; /* line number containing this call */ +Itcl_Assert( + const char *testExpr, /* string representing test expression */ + const char *fileName, /* file name containing this call */ + int lineNumber) /* line number containing this call */ { Tcl_Panic("Itcl Assertion failed: \"%s\" (line %d of %s)", testExpr, lineNumber, fileName); @@ -95,8 +87,8 @@ * ------------------------------------------------------------------------ */ void -Itcl_InitStack(stack) - Itcl_Stack *stack; /* stack to be initialized */ +Itcl_InitStack( + Itcl_Stack *stack) /* stack to be initialized */ { stack->values = stack->space; stack->max = sizeof(stack->space)/sizeof(ClientData); @@ -112,8 +104,8 @@ * ------------------------------------------------------------------------ */ void -Itcl_DeleteStack(stack) - Itcl_Stack *stack; /* stack to be deleted */ +Itcl_DeleteStack( + Itcl_Stack *stack) /* stack to be deleted */ { /* * If memory was explicitly allocated (instead of using the @@ -135,9 +127,9 @@ * ------------------------------------------------------------------------ */ void -Itcl_PushStack(cdata,stack) - ClientData cdata; /* data to be pushed onto stack */ - Itcl_Stack *stack; /* stack */ +Itcl_PushStack( + ClientData cdata, /* data to be pushed onto stack */ + Itcl_Stack *stack) /* stack */ { ClientData *newStack; @@ -166,14 +158,14 @@ * ------------------------------------------------------------------------ */ ClientData -Itcl_PopStack(stack) - Itcl_Stack *stack; /* stack to be manipulated */ +Itcl_PopStack( + Itcl_Stack *stack) /* stack to be manipulated */ { if (stack->values && (stack->len > 0)) { stack->len--; return stack->values[stack->len]; } - return (ClientData)NULL; + return NULL; } /* @@ -184,13 +176,13 @@ * ------------------------------------------------------------------------ */ ClientData -Itcl_PeekStack(stack) - Itcl_Stack *stack; /* stack to be examined */ +Itcl_PeekStack( + Itcl_Stack *stack) /* stack to be examined */ { if (stack->values && (stack->len > 0)) { return stack->values[stack->len-1]; } - return (ClientData)NULL; + return NULL; } /* @@ -202,15 +194,15 @@ * ------------------------------------------------------------------------ */ ClientData -Itcl_GetStackValue(stack,pos) - Itcl_Stack *stack; /* stack to be examined */ - int pos; /* get value at this index */ +Itcl_GetStackValue( + Itcl_Stack *stack, /* stack to be examined */ + int pos) /* get value at this index */ { if (stack->values && (stack->len > 0)) { assert(pos < stack->len); return stack->values[pos]; } - return (ClientData)NULL; + return NULL; } @@ -223,8 +215,8 @@ * ------------------------------------------------------------------------ */ void -Itcl_InitList(listPtr) - Itcl_List *listPtr; /* list to be initialized */ +Itcl_InitList( + Itcl_List *listPtr) /* list to be initialized */ { listPtr->validate = ITCL_VALID_LIST; listPtr->num = 0; @@ -243,8 +235,8 @@ * ------------------------------------------------------------------------ */ void -Itcl_DeleteList(listPtr) - Itcl_List *listPtr; /* list to be deleted */ +Itcl_DeleteList( + Itcl_List *listPtr) /* list to be deleted */ { Itcl_ListElem *elemPtr; @@ -298,8 +290,8 @@ * ------------------------------------------------------------------------ */ Itcl_ListElem* -Itcl_DeleteListElem(elemPtr) - Itcl_ListElem *elemPtr; /* list element to be deleted */ +Itcl_DeleteListElem( + Itcl_ListElem *elemPtr) /* list element to be deleted */ { Itcl_List *listPtr; Itcl_ListElem *nextPtr; @@ -342,9 +334,9 @@ * ------------------------------------------------------------------------ */ Itcl_ListElem* -Itcl_InsertList(listPtr,val) - Itcl_List *listPtr; /* list being modified */ - ClientData val; /* value associated with new element */ +Itcl_InsertList( + Itcl_List *listPtr, /* list being modified */ + ClientData val) /* value associated with new element */ { Itcl_ListElem *elemPtr; assert(listPtr->validate == ITCL_VALID_LIST); @@ -376,9 +368,9 @@ * ------------------------------------------------------------------------ */ Itcl_ListElem* -Itcl_InsertListElem(pos,val) - Itcl_ListElem *pos; /* insert just before this element */ - ClientData val; /* value associated with new element */ +Itcl_InsertListElem( + Itcl_ListElem *pos, /* insert just before this element */ + ClientData val) /* value associated with new element */ { Itcl_List *listPtr; Itcl_ListElem *elemPtr; @@ -418,9 +410,9 @@ * ------------------------------------------------------------------------ */ Itcl_ListElem* -Itcl_AppendList(listPtr,val) - Itcl_List *listPtr; /* list being modified */ - ClientData val; /* value associated with new element */ +Itcl_AppendList( + Itcl_List *listPtr, /* list being modified */ + ClientData val) /* value associated with new element */ { Itcl_ListElem *elemPtr; assert(listPtr->validate == ITCL_VALID_LIST); @@ -452,9 +444,9 @@ * ------------------------------------------------------------------------ */ Itcl_ListElem* -Itcl_AppendListElem(pos,val) - Itcl_ListElem *pos; /* insert just after this element */ - ClientData val; /* value associated with new element */ +Itcl_AppendListElem( + Itcl_ListElem *pos, /* insert just after this element */ + ClientData val) /* value associated with new element */ { Itcl_List *listPtr; Itcl_ListElem *elemPtr; @@ -492,14 +484,12 @@ * ------------------------------------------------------------------------ */ void -Itcl_SetListValue(elemPtr,val) - Itcl_ListElem *elemPtr; /* list element being modified */ - ClientData val; /* new value associated with element */ +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; } @@ -516,7 +506,7 @@ { Itcl_ListElem *listPtr; Itcl_ListElem *elemPtr; - + listPtr = listPool; while (listPtr != NULL) { elemPtr = listPtr; @@ -535,20 +525,24 @@ * * 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() * - * Registers a piece of data so that it will be freed when no longer - * 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. + * Asscociates with cdata (allocated by Itcl_Alloc()) a routine to + * be called when cdata should be freed. This routine will be called + * when the number of Itcl_ReleaseData() calls on cdata matches the + * number of Itcl_PreserveData() calls on cdata. * ------------------------------------------------------------------------ */ void @@ -556,52 +550,18 @@ 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; -} -#ifdef ITCL_PRESERVE_DEBUG -void -Itcl_DbDumpPreserveInfo( - const char *fileName) -{ - FOREACH_HASH_DECLS; - FILE *fd; - ItclPreserveInfo *ipiPtr; - ItclPreserveInfoEntry *ipiePtr; - size_t j; + /* Itcl memory block to ckalloc block */ + blk = ((PresMemoryPrefix *)cdata)-1; - if (fileName == NULL) { - fd = stderr; - } else { - fd = fopen(fileName, "w"); - } - fprintf(fd, "type\taddr\tfile\tline\n"); - FOREACH_HASH_VALUE(ipiPtr, &itclPreserveInfos) { - if (ipiPtr->refCount == 0) { - continue; - } - fprintf(stderr, "DAT!%p!%" TCL_LL_MODIFIER "u!\n", ipiPtr->clientData, (Tcl_WideUInt) ipiPtr->refCount); - for (j = 0; j < ipiPtr->numEntries; j++) { - ipiePtr = &ipiPtr->entries[j]; - if (ipiePtr->type != ITCL_PRESERVE_DELETED) { - fprintf(fd, "%s\t%p\t%s\t%d\n", - ipiePtr->type == ITCL_PRESERVE_INCR ? "INCR" : "DECR", - ipiPtr->clientData, ipiePtr->fileName, ipiePtr->line); - } - } - } - if (fd != stderr) { - fclose(fd); - } + /* Set new free proc */ + blk->freeProc = fproc; } -#endif /* * ------------------------------------------------------------------------ @@ -615,75 +575,22 @@ * freed. * ------------------------------------------------------------------------ */ -#ifdef ITCL_PRESERVE_DEBUG -void -ItclDbgPreserveData( - ClientData cdata, /* data to be preserved */ - int line, - const char *file) -{ - - /* - * If the clientData value is NULL, do nothing. - */ - if (cdata == NULL) { - return; - } - { - Tcl_HashEntry *hPtr; - ItclPreserveInfo *ipiPtr; - ItclPreserveInfoEntry *ipiePtr; - int isNew; - - if (!itclPreserveInfoInitted) { - Tcl_InitHashTable(&itclPreserveInfos, TCL_ONE_WORD_KEYS); - itclPreserveInfoInitted = 1; - } - hPtr = Tcl_CreateHashEntry(&itclPreserveInfos, cdata, &isNew); - if (isNew) { - ipiPtr = (ItclPreserveInfo *)ckalloc(sizeof(ItclPreserveInfo)); - ipiPtr->refCount = 0; - ipiPtr->size = ITCL_PRESERVE_BUCKET_SIZE; - ipiPtr->numEntries = 0; - ipiPtr->clientData = cdata; - ipiPtr->entries = (ItclPreserveInfoEntry *)malloc( - sizeof(ItclPreserveInfoEntry) * ipiPtr->size); - Tcl_SetHashValue(hPtr, ipiPtr); - } - ipiPtr = Tcl_GetHashValue(hPtr); - if (ipiPtr->numEntries >= ipiPtr->size) { - ipiPtr->size += ITCL_PRESERVE_BUCKET_SIZE; - ipiPtr->entries = (ItclPreserveInfoEntry *) - realloc((char *)ipiPtr->entries, - sizeof(ItclPreserveInfoEntry) * - ipiPtr->size); - } - ipiePtr = &ipiPtr->entries[ipiPtr->numEntries++]; - ipiePtr->type = ITCL_PRESERVE_INCR; - ipiePtr->line = line; - ipiePtr->fileName = file; - ipiPtr->refCount++; - } - - Tcl_Preserve(cdata); - return; -} -# else 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; } -#endif /* * ------------------------------------------------------------------------ @@ -695,72 +602,89 @@ * automatically freed. * ------------------------------------------------------------------------ */ -#ifdef ITCL_PRESERVE_DEBUG void -ItclDbgReleaseData( - ClientData cdata, /* data to be released */ - int line, - const char *file) +Itcl_ReleaseData( + ClientData cdata) /* data to be released */ { + PresMemoryPrefix *blk; + Tcl_FreeProc *freeProc; - int noDelete = 0; - - /* - * If the clientData value is NULL, do nothing. - */ if (cdata == NULL) { return; } - { - Tcl_HashEntry *hPtr; - ItclPreserveInfo *ipiPtr; - ItclPreserveInfoEntry *ipiePtr; - - if (!itclPreserveInfoInitted) { - Tcl_InitHashTable(&itclPreserveInfos, TCL_ONE_WORD_KEYS); - itclPreserveInfoInitted = 1; - } - hPtr = Tcl_FindHashEntry(&itclPreserveInfos, cdata); - if (hPtr != NULL) { - ipiPtr = Tcl_GetHashValue(hPtr); - if (ipiPtr->numEntries >= ipiPtr->size) { - ipiPtr->size += ITCL_PRESERVE_BUCKET_SIZE; - ipiPtr->entries = (ItclPreserveInfoEntry *) - realloc((char *)ipiPtr->entries, - sizeof(ItclPreserveInfoEntry) * - ipiPtr->size); - } - ipiePtr = &ipiPtr->entries[ipiPtr->numEntries++]; - ipiePtr->type = ITCL_PRESERVE_DECR; - ipiePtr->line = line; - ipiePtr->fileName = file; - if (ipiPtr->refCount-- == 0) { - fprintf(stderr, "REFCOUNT < 0 for: %p!\n", cdata); - noDelete = 1; - } - } - } - if (!noDelete) { - Tcl_Release(cdata); + + /* 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; } - return; + + /* Free cdata now */ + freeProc = blk->freeProc; + blk->freeProc = NULL; + freeProc(cdata); } -#else -void -Itcl_ReleaseData( - ClientData cdata) /* data to be released */ + +/* + * ------------------------------------------------------------------------ + * 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; - /* - * If the clientData value is NULL, do nothing. - */ - if (cdata == NULL) { - return; + /* 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; } - Tcl_Release(cdata); - 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); } -#endif /* * ------------------------------------------------------------------------ @@ -780,9 +704,9 @@ * ------------------------------------------------------------------------ */ Itcl_InterpState -Itcl_SaveInterpState(interp, status) - Tcl_Interp* interp; /* interpreter being modified */ - int status; /* integer status code for current operation */ +Itcl_SaveInterpState( + Tcl_Interp* interp, /* interpreter being modified */ + int status) /* integer status code for current operation */ { return (Itcl_InterpState) Tcl_SaveInterpState(interp, status); } @@ -802,9 +726,9 @@ * ------------------------------------------------------------------------ */ int -Itcl_RestoreInterpState(interp, state) - Tcl_Interp* interp; /* interpreter being modified */ - Itcl_InterpState state; /* token representing interpreter state */ +Itcl_RestoreInterpState( + Tcl_Interp* interp, /* interpreter being modified */ + Itcl_InterpState state) /* token representing interpreter state */ { return Tcl_RestoreInterpState(interp, (Tcl_InterpState)state); } @@ -822,8 +746,8 @@ * ------------------------------------------------------------------------ */ void -Itcl_DiscardInterpState(state) - Itcl_InterpState state; /* token representing interpreter state */ +Itcl_DiscardInterpState( + Itcl_InterpState state) /* token representing interpreter state */ { Tcl_DiscardInterpState((Tcl_InterpState)state); return; @@ -846,9 +770,9 @@ * ------------------------------------------------------------------------ */ int -Itcl_Protection(interp, newLevel) - Tcl_Interp *interp; /* interpreter being queried */ - int newLevel; /* new protection level or 0 */ +Itcl_Protection( + Tcl_Interp *interp, /* interpreter being queried */ + int newLevel) /* new protection level or 0 */ { int oldVal; ItclObjectInfo *infoPtr; @@ -858,7 +782,7 @@ * In any case, return the protection level as it stands right now. */ infoPtr = (ItclObjectInfo*) Tcl_GetAssocData(interp, ITCL_INTERP_DATA, - (Tcl_InterpDeleteProc**)NULL); + NULL); assert(infoPtr != NULL); oldVal = infoPtr->protection; @@ -899,7 +823,7 @@ const char **head, /* returns "namesp::namesp::namesp" part */ const char **tail) /* returns "element" part */ { - register char *sep, *newname; + char *sep, *newname; Tcl_DStringInit(buffer); @@ -995,7 +919,7 @@ if (entry == NULL) { return 0; } - fromIclsPtr = Tcl_GetHashValue(entry); + fromIclsPtr = (ItclClass *)Tcl_GetHashValue(entry); entry = Tcl_FindHashEntry(&fromIclsPtr->heritage, (char*)iclsPtr); @@ -1078,7 +1002,7 @@ if (hPtr == NULL) { return 0; } - fromIclsPtr = Tcl_GetHashValue(hPtr); + fromIclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); if (Tcl_FindHashEntry(&iclsPtr->heritage, (char*)fromIclsPtr)) { entry = Tcl_FindHashEntry(&fromIclsPtr->resolveCmds, @@ -1130,10 +1054,10 @@ int listc; int result; int len; - + nsPtr = NULL; len = strlen(name); - cmdName = ckalloc((unsigned)strlen(name)+1); + cmdName = (char *)ckalloc(strlen(name)+1); strcpy(cmdName, name); if ((*name == 'n') && (len > 17) && (strncmp(name, "namespace", 9) == 0)) { @@ -1150,17 +1074,17 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "malformed command \"", name, "\": should be \"", "namespace inscope namesp command\"", - (char*)NULL); + NULL); result = TCL_ERROR; } else { nsPtr = Tcl_FindNamespace(interp, listv[2], - (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); + NULL, TCL_LEAVE_ERR_MSG); if (nsPtr == NULL) { result = TCL_ERROR; } else { ckfree(cmdName); - cmdName = ckalloc((unsigned)(strlen(listv[3])+1)); + cmdName = (char *)ckalloc(strlen(listv[3])+1); strcpy(cmdName, listv[3]); } } @@ -1181,22 +1105,3 @@ *rCmdPtr = cmdName; return TCL_OK; } - -#ifdef ITCL_PRESERVE_DEBUG -#undef Itcl_PreserveData -#undef Itcl_ReleaseData - -void -Itcl_PreserveData( - ClientData cdata) -{ - ItclDbgPreserveData(cdata, 0, ""); -} - -void -Itcl_ReleaseData( - ClientData cdata) -{ - ItclDbgReleaseData(cdata, 0, ""); -} -#endif diff -Nru itcl4-4.1.2/generic/itclVarsAndCmds.c itcl4-4.2.0/generic/itclVarsAndCmds.c --- itcl4-4.1.2/generic/itclVarsAndCmds.c 2011-11-09 16:40:33.000000000 +0000 +++ itcl4-4.2.0/generic/itclVarsAndCmds.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,234 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * PACKAGE: [incr Tcl] - * DESCRIPTION: Object-Oriented Extensions to Tcl - * - * These procedures handle command and variable resolution - * - * ======================================================================== - * AUTHOR: Arnulf Wiedemann - * - * ======================================================================== - * Copyright (c) Arnulf Wiedemann - * ------------------------------------------------------------------------ - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include -#include "itclInt.h" -#include "itclVCInt.h" - -#ifdef NEW_PROTO_RESOLVER -static void -ItclDeleteResolveInfo( - ClientData clientData, - Tcl_Interp *interp) -{ - ckfree((char *)clientData); -} -#endif - -int -ItclVarsAndCommandResolveInit( - Tcl_Interp *interp) -{ -#ifdef NEW_PROTO_RESOLVER - ItclResolvingInfo *iriPtr; - - /* - * 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. - */ - iriPtr = (ItclResolvingInfo*)ckalloc(sizeof(ItclResolvingInfo)); - memset(iriPtr, 0, sizeof(ItclResolvingInfo)); - iriPtr->interp = interp; - Tcl_InitHashTable(&iriPtr->resolveVars, TCL_ONE_WORD_KEYS); - Tcl_InitHashTable(&iriPtr->resolveCmds, TCL_ONE_WORD_KEYS); - Tcl_InitHashTable(&iriPtr->objectVarsTables, TCL_ONE_WORD_KEYS); - Tcl_InitHashTable(&iriPtr->objectCmdsTables, TCL_ONE_WORD_KEYS); - - Tcl_SetAssocData(interp, ITCL_RESOLVE_DATA, - (Tcl_InterpDeleteProc*)ItclDeleteResolveInfo, (ClientData)iriPtr); - Tcl_Preserve((ClientData)iriPtr); - - Itcl_SetClassCommandProtectionCallback(interp, NULL, - Itcl_CheckClassCommandProtection); - Itcl_SetClassVariableProtectionCallback(interp, NULL, - Itcl_CheckClassVariableProtection); -#endif - return TCL_OK; -} - -ClientData -Itcl_RegisterClassVariable( - Tcl_Interp *interp, - Tcl_Namespace *nsPtr, - const char *varName, - ClientData clientData) -{ - Tcl_HashTable *tablePtr; - Tcl_HashEntry *hPtr; - ItclResolvingInfo *iriPtr; - int isNew; - - iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); - hPtr = Tcl_CreateHashEntry(&iriPtr->resolveVars, nsPtr->fullName, &isNew); - if (isNew) { - tablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); - Tcl_SetHashValue(hPtr, tablePtr); - - } else { - tablePtr = Tcl_GetHashValue(hPtr); - } - hPtr = Tcl_CreateHashEntry(tablePtr, varName, &isNew); - if (isNew) { - Tcl_SetHashValue(hPtr, clientData); - } - return Tcl_GetHashValue(hPtr); -} - -ClientData -Itcl_RegisterClassCommand( - Tcl_Interp *interp, - Tcl_Namespace *nsPtr, - const char *cmdName, - ClientData clientData) -{ - Tcl_HashEntry *hPtr; - Tcl_HashTable *tablePtr; - ItclResolvingInfo *iriPtr; - int isNew; - - iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); - hPtr = Tcl_CreateHashEntry(&iriPtr->resolveCmds, nsPtr->fullName, &isNew); - if (isNew) { - tablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); - Tcl_SetHashValue(hPtr, tablePtr); - - } else { - tablePtr = Tcl_GetHashValue(hPtr); - } - hPtr = Tcl_CreateHashEntry(tablePtr, cmdName, &isNew); - if (isNew) { - Tcl_SetHashValue(hPtr, clientData); - } - return Tcl_GetHashValue(hPtr); -} - -Tcl_Var -Itcl_RegisterObjectVariable( - Tcl_Interp *interp, - ItclObject *ioPtr, - const char *varName, - ClientData clientData, - Tcl_Var varPtr, - Tcl_Namespace *nsPtr) -{ - Tcl_HashEntry *hPtr; - ItclResolvingInfo *iriPtr; - ObjectVarTableInfo *ovtiPtr; - ObjectVarInfo *oviPtr; - int isNew; - - iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); - hPtr = Tcl_CreateHashEntry(&iriPtr->objectVarsTables, - (char *)ioPtr, &isNew); - if (isNew) { - ovtiPtr = (ObjectVarTableInfo *)ckalloc(sizeof(ObjectVarTableInfo)); - Tcl_InitHashTable(&ovtiPtr->varInfos, TCL_ONE_WORD_KEYS); - ovtiPtr->tablePtr = &((Namespace *)nsPtr)->varTable; - Tcl_SetHashValue(hPtr, ovtiPtr); - } else { - ovtiPtr = Tcl_GetHashValue(hPtr); - } - hPtr = Tcl_CreateHashEntry(&ovtiPtr->varInfos, (char *)clientData, &isNew); - if (isNew) { - oviPtr = (ObjectVarInfo *)ckalloc(sizeof(ObjectVarInfo)); - memset(oviPtr, 0, sizeof(ObjectVarInfo)); - Tcl_SetHashValue(hPtr, oviPtr); - } else { - oviPtr = Tcl_GetHashValue(hPtr); - } - oviPtr->clientData = clientData; - oviPtr->ioPtr = ioPtr; - if (varPtr == NULL) { - varPtr = Tcl_NewNamespaceVar(interp, nsPtr, varName); - } - oviPtr->varPtr = varPtr; - return varPtr; -} - -Tcl_Command -Itcl_RegisterObjectCommand( - Tcl_Interp *interp, - ItclObject *ioPtr, - const char *cmdName, - ClientData clientData, - Tcl_Command cmdPtr, - Tcl_Namespace *nsPtr) -{ - Tcl_HashEntry *hPtr; - ItclResolvingInfo *iriPtr; - ObjectCmdTableInfo *octiPtr; - ObjectCmdInfo *ociPtr; - int isNew; - - iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); - hPtr = Tcl_CreateHashEntry(&iriPtr->objectCmdsTables, - (char *)ioPtr, &isNew); - if (isNew) { - octiPtr = (ObjectCmdTableInfo *)ckalloc(sizeof(ObjectCmdTableInfo)); - Tcl_InitHashTable(&octiPtr->cmdInfos, TCL_ONE_WORD_KEYS); - octiPtr->tablePtr = &((Namespace *)nsPtr)->cmdTable; - Tcl_SetHashValue(hPtr, octiPtr); - } else { - octiPtr = Tcl_GetHashValue(hPtr); - } - hPtr = Tcl_CreateHashEntry(&octiPtr->cmdInfos, (char *)clientData, &isNew); - if (isNew) { - ociPtr = (ObjectCmdInfo *)ckalloc(sizeof(ObjectCmdInfo)); - memset(ociPtr, 0, sizeof(ObjectCmdInfo)); - Tcl_SetHashValue(hPtr, ociPtr); - } else { - ociPtr = Tcl_GetHashValue(hPtr); - } - ociPtr->clientData = clientData; - ociPtr->ioPtr = ioPtr; - if (cmdPtr == NULL) { -/* - cmdPtr = Tcl_NewNamespaceVar(interp, nsPtr, varName); -*/ - } - ociPtr->cmdPtr = cmdPtr; - return cmdPtr; -} - -int -Itcl_SetClassVariableProtectionCallback( - Tcl_Interp *interp, - Tcl_Namespace *nsPtr, - ItclCheckClassProtection *fcnPtr) -{ - ItclResolvingInfo *iriPtr; - - iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); - iriPtr->varProtFcn = fcnPtr; - return TCL_OK; -} - -int -Itcl_SetClassCommandProtectionCallback( - Tcl_Interp *interp, - Tcl_Namespace *nsPtr, - ItclCheckClassProtection *fcnPtr) -{ - ItclResolvingInfo *iriPtr; - - iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL); - iriPtr->cmdProtFcn = fcnPtr; - return TCL_OK; -} diff -Nru itcl4-4.1.2/generic/itclVarsAndCmds.h itcl4-4.2.0/generic/itclVarsAndCmds.h --- itcl4-4.1.2/generic/itclVarsAndCmds.h 2011-07-19 15:44:53.000000000 +0000 +++ itcl4-4.2.0/generic/itclVarsAndCmds.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -/* - * ------------------------------------------------------------------------ - * PACKAGE: [incr Tcl] - * DESCRIPTION: Object-Oriented Extensions to Tcl - * - * These procedures handle command and variable resolution - * - * ======================================================================== - * AUTHOR: Arnulf Wiedemann - * - * ======================================================================== - * Copyright (c) Arnulf Wiedemann - * ------------------------------------------------------------------------ - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -typedef int (ItclCheckClassProtection)(Tcl_Interp *interp, - Tcl_Namespace *nsPtr, const char *varName, ClientData clientData); - -ClientData Itcl_RegisterClassVariable(Tcl_Interp *interp, - Tcl_Namespace *nsPtr, const char *varName, ClientData clientData); - -Tcl_Var Itcl_RegisterObjectVariable( Tcl_Interp *interp, ItclObject *ioPtr, - const char *varName, ClientData clientData, Tcl_Var varPtr, - Tcl_Namespace *nsPtr); - -ClientData Itcl_RegisterClassCommand(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - const char *cmdName, ClientData clientData); - -Tcl_Command Itcl_RegisterObjectCommand( Tcl_Interp *interp, ItclObject *ioPtr, - const char *cmdName, ClientData clientData, Tcl_Command cmdPtr, - Tcl_Namespace *nsPtr); - -int Itcl_CheckClassVariableProtection(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - const char *varName, ClientData clientData); - -int Itcl_CheckClassCommandProtection(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - const char *cmdName, ClientData clientData); - -int Itcl_SetClassVariableProtectionCallback(Tcl_Interp *interp, - Tcl_Namespace *nsPtr, ItclCheckClassProtection *fcnPtr); - -int Itcl_SetClassCommandProtectionCallback(Tcl_Interp *interp, - Tcl_Namespace *nsPtr, ItclCheckClassProtection *fcnPtr); - diff -Nru itcl4-4.1.2/generic/itclVCInt.h itcl4-4.2.0/generic/itclVCInt.h --- itcl4-4.1.2/generic/itclVCInt.h 2011-07-19 15:44:53.000000000 +0000 +++ itcl4-4.2.0/generic/itclVCInt.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,37 +0,0 @@ -#define ITCL_RESOLVE_DATA "ITCL_Resolve_Info" - -typedef struct ItclResolvngInfo { - Tcl_Interp *interp; - Tcl_HashTable resolveVars; /* all possible names for variables in - * this class (e.g., x, foo::x, etc.) */ - Tcl_HashTable resolveCmds; /* all possible names for functions in - * this class (e.g., x, foo::x, etc.) */ - ItclCheckClassProtection *varProtFcn; - ItclCheckClassProtection *cmdProtFcn; - Tcl_HashTable objectVarsTables; - Tcl_HashTable objectCmdsTables; -} ItclResolvingInfo; - -typedef struct ObjectVarInfo { - ClientData clientData; - ItclObject *ioPtr; - Tcl_Var varPtr; -} ObjectVarInfo; - -typedef struct ObjectVarTableInfo { - Tcl_HashTable varInfos; - TclVarHashTable *tablePtr; -} ObjectVarTableInfo; - -typedef struct ObjectCmdInfo { - ClientData clientData; - ItclObject *ioPtr; - Tcl_Command cmdPtr; -} ObjectCmdInfo; - -typedef struct ObjectCmdTableInfo { - Tcl_HashTable cmdInfos; - Tcl_HashTable *tablePtr; -} ObjectCmdTableInfo; - - diff -Nru itcl4-4.1.2/itclConfig.sh.in itcl4-4.2.0/itclConfig.sh.in --- itcl4-4.1.2/itclConfig.sh.in 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/itclConfig.sh.in 2019-10-04 16:02:02.000000000 +0000 @@ -1,5 +1,5 @@ # itclConfig.sh -- -# +# # This shell script (for sh) is generated automatically by Itcl's # configure script. It will create shell variables for most of # the configuration options discovered by the configure script. diff -Nru itcl4-4.1.2/library/itclHullCmds.tcl itcl4-4.2.0/library/itclHullCmds.tcl --- itcl4-4.1.2/library/itclHullCmds.tcl 2014-02-19 17:45:13.000000000 +0000 +++ itcl4-4.2.0/library/itclHullCmds.tcl 2019-10-04 16:02:02.000000000 +0000 @@ -125,7 +125,7 @@ rename ${tmp}_ ::$tmp set exists [uplevel 1 ::info exists itcl_hull] if {!$exists} { - # that does not yet work, beacause of problems with resolving + # that does not yet work, beacause of problems with resolving ::itcl::addcomponent $my_this itcl_hull } upvar itcl_hull itcl_hull @@ -133,7 +133,7 @@ #puts stderr "IC![::info command $my_win]!" set exists [uplevel 1 ::info exists itcl_interior] if {!$exists} { - # that does not yet work, beacause of problems with resolving + # that does not yet work, beacause of problems with resolving ::itcl::addcomponent $this itcl_interior } upvar itcl_interior itcl_interior @@ -196,7 +196,7 @@ } } } - + # ======================= setupcomponent =========================== proc setupcomponent {comp using widget_type path args} { diff -Nru itcl4-4.1.2/library/itclWidget.tcl itcl4-4.2.0/library/itclWidget.tcl --- itcl4-4.1.2/library/itclWidget.tcl 2017-12-08 13:09:27.000000000 +0000 +++ itcl4-4.2.0/library/itclWidget.tcl 2019-10-04 16:02:02.000000000 +0000 @@ -19,14 +19,14 @@ proc widget {name args} { set result [uplevel 1 ::itcl::internal::commands::genericclass widget $name $args] - # we handle create by owerselfs !! allow classunknown to handle that + # we handle create by owerselfs !! allow classunknown to handle that oo::objdefine $result unexport create return $result } proc widgetadaptor {name args} { set result [uplevel 1 ::itcl::internal::commands::genericclass widgetadaptor $name $args] - # we handle create by owerselfs !! allow classunknown to handle that + # we handle create by owerselfs !! allow classunknown to handle that oo::objdefine $result unexport create return $result } @@ -334,7 +334,7 @@ namespace upvar ::itcl::internal::dicts hullTypes hullTypes set numArgs [llength $args] - if {$numArgs > 1} { + if {$numArgs > 1} { error "wrong # args should be: info hulltypes ??" } set pattern "" @@ -350,7 +350,7 @@ proc widgetclasses {args} { set numArgs [llength $args] - if {$numArgs > 1} { + if {$numArgs > 1} { error "wrong # args should be: info widgetclasses ??" } set pattern "" @@ -382,7 +382,7 @@ proc widgets {args} { set numArgs [llength $args] - if {$numArgs > 1} { + if {$numArgs > 1} { error "wrong # args should be: info widgets ??" } set pattern "" @@ -414,7 +414,7 @@ proc widgetadaptors {args} { set numArgs [llength $args] - if {$numArgs > 1} { + if {$numArgs > 1} { error "wrong # args should be: info widgetadaptors ??" } set pattern "" diff -Nru itcl4-4.1.2/library/test_Itcl_CreateObject.tcl itcl4-4.2.0/library/test_Itcl_CreateObject.tcl --- itcl4-4.1.2/library/test_Itcl_CreateObject.tcl 2014-09-14 18:47:42.000000000 +0000 +++ itcl4-4.2.0/library/test_Itcl_CreateObject.tcl 2019-10-04 16:02:02.000000000 +0000 @@ -1,7 +1,7 @@ # this is a program for testing the stubs interface ItclCreateObject. # it uses itclTestRegisterC.c with the call C function functionality, # so it also tests that feature. -# you need to define in Makefile CFLAGS: -DITCL_DEBUG_C_INTERFACE +# you need to define in Makefile CFLAGS: -DITCL_DEBUG_C_INTERFACE # for makeing that work. package require itcl diff -Nru itcl4-4.1.2/license.terms itcl4-4.2.0/license.terms --- itcl4-4.1.2/license.terms 2011-07-19 15:44:53.000000000 +0000 +++ itcl4-4.2.0/license.terms 2019-10-04 16:02:02.000000000 +0000 @@ -35,7 +35,7 @@ GOVERNMENT USE: If you are acquiring this software on behalf of the U.S. government, the Government shall have only "Restricted Rights" -in the software and related documentation as defined in the Federal +in the software and related documentation as defined in the Federal Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are acquiring the software on behalf of the Department of Defense, the software shall be classified as "Commercial Computer Software" and the @@ -43,4 +43,4 @@ 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the authors grant the U.S. Government and others acting in its behalf permission to use and distribute the software in accordance with the -terms specified in this license. +terms specified in this license. diff -Nru itcl4-4.1.2/Makefile.in itcl4-4.2.0/Makefile.in --- itcl4-4.1.2/Makefile.in 2018-10-16 17:23:32.000000000 +0000 +++ itcl4-4.2.0/Makefile.in 2019-10-04 16:02:02.000000000 +0000 @@ -141,6 +141,10 @@ TCLSH_PROG = @TCLSH_PROG@ TCLSH = $(TCLSH_ENV) $(PKG_ENV) $(TCLSH_PROG) +TESTLOADARG = if {[catch {package present ${PACKAGE_NAME}}]} {package forget ${PACKAGE_NAME}}; \ + package ifneeded ${PACKAGE_NAME} ${PACKAGE_VERSION} \ + [list load `@CYGPATH@ $(top_builddir)/$(PKG_LIB_FILE)` $(PACKAGE_NAME)] + #WISH_ENV = TK_LIBRARY=`@CYGPATH@ $(TK_SRC_DIR)/library` #WISH_PROG = @WISH_PROG@ #WISH = $(PKG_ENV) $(TCLSH_ENV) $(WISH_ENV) $(WISH_PROG) @@ -168,7 +172,7 @@ CPPFLAGS = @CPPFLAGS@ LIBS = @PKG_LIBS@ @LIBS@ AR = @AR@ -CFLAGS = @CFLAGS@ +CFLAGS = @CFLAGS@ -DTCL_NO_DEPRECATED COMPILE = $(CC) $(DEFS) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) GDB = gdb @@ -246,10 +250,7 @@ done test: binaries libraries - $(TCLSH) `@CYGPATH@ $(srcdir)/tests/all.tcl` $(TESTFLAGS) \ - -load "if {[catch {package present ${PACKAGE_NAME}}]} {package forget ${PACKAGE_NAME}; \ - package ifneeded ${PACKAGE_NAME} ${PACKAGE_VERSION} \ - [list load `@CYGPATH@ $(PKG_LIB_FILE)` $(PACKAGE_NAME)]}" + $(TCLSH) `@CYGPATH@ $(srcdir)/tests/all.tcl` $(TESTFLAGS) -load "$(TESTLOADARG)" shell: binaries libraries @$(TCLSH) $(SCRIPT) @@ -257,12 +258,10 @@ gdb: $(TCLSH_ENV) $(PKG_ENV) $(GDB) $(TCLSH_PROG) $(SCRIPT) -gdb-test: binaries libraries +gdb-test: binaries libraries $(TCLSH_ENV) $(PKG_ENV) $(GDB) \ --args $(TCLSH_PROG) `@CYGPATH@ $(srcdir)/tests/all.tcl` \ - $(TESTFLAGS) -singleproc 1 \ - -load "package ifneeded $(PACKAGE_NAME) $(PACKAGE_VERSION) \ - [list load `@CYGPATH@ $(PKG_LIB_FILE)` $(PACKAGE_NAME)]" + $(TESTFLAGS) -singleproc 1 -load "$(TESTLOADARG)" valgrind: binaries libraries $(TCLSH_ENV) $(PKG_ENV) $(VALGRIND) $(VALGRINDARGS) $(TCLSH_PROG) \ diff -Nru itcl4-4.1.2/pkgIndex.tcl.in itcl4-4.2.0/pkgIndex.tcl.in --- itcl4-4.1.2/pkgIndex.tcl.in 2017-12-14 13:33:01.000000000 +0000 +++ itcl4-4.2.0/pkgIndex.tcl.in 2019-11-03 02:24:15.000000000 +0000 @@ -1,6 +1,21 @@ # Tcl package index file, version 1.0 +# +# Do NOT try this command +# +# if {![package vsatisfies [package provide Tcl] 8.6-]} {return} +# +# as a way to accept working with all of Tcl 8.6, Tcl 8.X, X>6, and +# Tcl Y, for Y > 8. +# Itcl is a binary package, added to an interp with [load]. +# There is no libitcl.so that will [load] into both Tcl 8 and Tcl 9. +# The indexed libitcl.so was built to [load] into one or the other. +# Thus the pkgIndex.tcl should only accept the version of Tcl for which +# the indexed @PKG_LIB_FILE@ was built. +# +# More work replacing the literal "8.6" below with the proper value substituted +# by configure is the right way forward. -if {![package vsatisfies [package provide Tcl] 8.6-]} {return} +if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded itcl @PACKAGE_VERSION@ [list load [file join $dir "@PKG_LIB_FILE@"] itcl] package ifneeded Itcl @PACKAGE_VERSION@ [list load [file join $dir "@PKG_LIB_FILE@"] itcl] diff -Nru itcl4-4.1.2/README itcl4-4.2.0/README --- itcl4-4.1.2/README 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/README 2019-11-03 02:31:34.000000000 +0000 @@ -1,6 +1,6 @@ README: Itcl -This is the 4.1.2 source distribution of Itcl, an object oriented +This is the 4.2.0 source distribution of Itcl, an object oriented extension for Tcl. Itcl releases are available from Sourceforge at: https://sourceforge.net/projects/incrtcl/files/%5Bincr%20Tcl_Tk%5D-4-source/ @@ -11,7 +11,7 @@ for the itcl extension. This version is the next major release to follow Itcl 3.4. This version claims to be script level compatible with Itcl 3.4. -Itcl is a freely-available open source package as in the past. +Itcl is a freely-available open source package as in the past. You can do virtually anything you like with it, such as modifying it, redistributing it, and selling it either in whole or in part. See the file "license.terms" for complete information. diff -Nru itcl4-4.1.2/tclconfig/tcl.m4 itcl4-4.2.0/tclconfig/tcl.m4 --- itcl4-4.1.2/tclconfig/tcl.m4 2018-10-17 16:51:27.000000000 +0000 +++ itcl4-4.2.0/tclconfig/tcl.m4 2019-11-03 02:28:59.000000000 +0000 @@ -104,7 +104,6 @@ for i in `ls -d ~/Library/Frameworks 2>/dev/null` \ `ls -d /Library/Frameworks 2>/dev/null` \ `ls -d /Network/Library/Frameworks 2>/dev/null` \ - `ls -d /System/Library/Frameworks 2>/dev/null` \ `ls -d /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/Library/Frameworks/Tcl.framework 2>/dev/null` \ `ls -d /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/Network/Library/Frameworks/Tcl.framework 2>/dev/null` \ `ls -d /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/System/Library/Frameworks/Tcl.framework 2>/dev/null` \ @@ -267,7 +266,6 @@ for i in `ls -d ~/Library/Frameworks 2>/dev/null` \ `ls -d /Library/Frameworks 2>/dev/null` \ `ls -d /Network/Library/Frameworks 2>/dev/null` \ - `ls -d /System/Library/Frameworks 2>/dev/null` \ `ls -d /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/Library/Frameworks/Tcl.framework 2>/dev/null` \ `ls -d /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/Network/Library/Frameworks/Tcl.framework 2>/dev/null` \ `ls -d /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/System/Library/Frameworks/Tcl.framework 2>/dev/null` \ @@ -440,7 +438,8 @@ #error win32 #endif ], [ - TEA_PLATFORM="unix" + # first test we've already retrieved platform (cross-compile), fallback to unix otherwise: + TEA_PLATFORM="${TEA_PLATFORM-unix}" CYGPATH=echo ], [ TEA_PLATFORM="windows" @@ -883,14 +882,6 @@ that IS thread-enabled. It is recommended to use --enable-threads.]) fi ;; - *) - if test "${TCL_THREADS}" = "1"; then - AC_MSG_WARN([ - --enable-threads requested, but building against a Tcl that is NOT - thread-enabled. This is an OK configuration that will also run in - a thread-enabled core.]) - fi - ;; esac AC_SUBST(TCL_THREADS) ]) @@ -1021,6 +1012,7 @@ # Defines the following var: # # system - System/platform/version identification code. +# #-------------------------------------------------------------------- AC_DEFUN([TEA_CONFIG_SYSTEM], [ @@ -1037,6 +1029,9 @@ if test "`uname -s`" = "AIX" ; then tcl_cv_sys_version=AIX-`uname -v`.`uname -r` fi + if test "`uname -s`" = "NetBSD" -a -f /etc/debian_version ; then + tcl_cv_sys_version=NetBSD-Debian + fi fi fi ]) @@ -1156,17 +1151,6 @@ [doRpath=$enableval], [doRpath=yes]) AC_MSG_RESULT([$doRpath]) - # TEA specific: Cross-compiling options for Windows/CE builds? - - AS_IF([test "${TEA_PLATFORM}" = windows], [ - AC_MSG_CHECKING([if Windows/CE build is requested]) - AC_ARG_ENABLE(wince, - AC_HELP_STRING([--enable-wince], - [enable Win/CE support (where applicable)]), - [doWince=$enableval], [doWince=no]) - AC_MSG_RESULT([$doWince]) - ]) - # Set the variable "system" to hold the name and version number # for the system. @@ -1239,65 +1223,6 @@ fi fi - if test "$doWince" != "no" ; then - if test "$do64bit" != "no" ; then - AC_MSG_ERROR([Windows/CE and 64-bit builds incompatible]) - fi - if test "$GCC" = "yes" ; then - AC_MSG_ERROR([Windows/CE and GCC builds incompatible]) - fi - TEA_PATH_CELIB - # Set defaults for common evc4/PPC2003 setup - # Currently Tcl requires 300+, possibly 420+ for sockets - CEVERSION=420; # could be 211 300 301 400 420 ... - TARGETCPU=ARMV4; # could be ARMV4 ARM MIPS SH3 X86 ... - ARCH=ARM; # could be ARM MIPS X86EM ... - PLATFORM="Pocket PC 2003"; # or "Pocket PC 2002" - if test "$doWince" != "yes"; then - # If !yes then the user specified something - # Reset ARCH to allow user to skip specifying it - ARCH= - eval `echo $doWince | awk -F, '{ \ - if (length([$]1)) { printf "CEVERSION=\"%s\"\n", [$]1; \ - if ([$]1 < 400) { printf "PLATFORM=\"Pocket PC 2002\"\n" } }; \ - if (length([$]2)) { printf "TARGETCPU=\"%s\"\n", toupper([$]2) }; \ - if (length([$]3)) { printf "ARCH=\"%s\"\n", toupper([$]3) }; \ - if (length([$]4)) { printf "PLATFORM=\"%s\"\n", [$]4 }; \ - }'` - if test "x${ARCH}" = "x" ; then - ARCH=$TARGETCPU; - fi - fi - OSVERSION=WCE$CEVERSION; - if test "x${WCEROOT}" = "x" ; then - WCEROOT="C:/Program Files/Microsoft eMbedded C++ 4.0" - if test ! -d "${WCEROOT}" ; then - WCEROOT="C:/Program Files/Microsoft eMbedded Tools" - fi - fi - if test "x${SDKROOT}" = "x" ; then - SDKROOT="C:/Program Files/Windows CE Tools" - if test ! -d "${SDKROOT}" ; then - SDKROOT="C:/Windows CE Tools" - fi - fi - WCEROOT=`echo "$WCEROOT" | sed -e 's!\\\!/!g'` - SDKROOT=`echo "$SDKROOT" | sed -e 's!\\\!/!g'` - if test ! -d "${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}" \ - -o ! -d "${WCEROOT}/EVC/${OSVERSION}/bin"; then - AC_MSG_ERROR([could not find PocketPC SDK or target compiler to enable WinCE mode [$CEVERSION,$TARGETCPU,$ARCH,$PLATFORM]]) - doWince="no" - else - # We could PATH_NOSPACE these, but that's not important, - # as long as we quote them when used. - CEINCLUDE="${SDKROOT}/${OSVERSION}/${PLATFORM}/include" - if test -d "${CEINCLUDE}/${TARGETCPU}" ; then - CEINCLUDE="${CEINCLUDE}/${TARGETCPU}" - fi - CELIBPATH="${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}" - fi - fi - if test "$GCC" != "yes" ; then if test "${SHARED_BUILD}" = "0" ; then runtime=-MT @@ -1325,32 +1250,6 @@ # Avoid 'unresolved external symbol __security_cookie' # errors, c.f. http://support.microsoft.com/?id=894573 TEA_ADD_LIBS([bufferoverflowU.lib]) - elif test "$doWince" != "no" ; then - CEBINROOT="${WCEROOT}/EVC/${OSVERSION}/bin" - if test "${TARGETCPU}" = "X86"; then - CC="\"${CEBINROOT}/cl.exe\"" - else - CC="\"${CEBINROOT}/cl${ARCH}.exe\"" - fi - CFLAGS="$CFLAGS -I\"${CELIB_DIR}/inc\" -I\"${CEINCLUDE}\"" - RC="\"${WCEROOT}/Common/EVC/bin/rc.exe\"" - arch=`echo ${ARCH} | awk '{print tolower([$]0)}'` - defs="${ARCH} _${ARCH}_ ${arch} PALM_SIZE _MT _WINDOWS" - if test "${SHARED_BUILD}" = "1" ; then - # Static CE builds require static celib as well - defs="${defs} _DLL" - fi - for i in $defs ; do - AC_DEFINE_UNQUOTED($i, 1, [WinCE def ]$i) - done - AC_DEFINE_UNQUOTED(_WIN32_WCE, $CEVERSION, [_WIN32_WCE version]) - AC_DEFINE_UNQUOTED(UNDER_CE, $CEVERSION, [UNDER_CE version]) - CFLAGS_DEBUG="-nologo -Zi -Od" - CFLAGS_OPTIMIZE="-nologo -Ox" - lversion=`echo ${CEVERSION} | sed -e 's/\(.\)\(..\)/\1\.\2/'` - lflags="${lflags} -MACHINE:${ARCH} -LIBPATH:\"${CELIBPATH}\" -subsystem:windowsce,${lversion} -nologo" - LINKBIN="\"${CEBINROOT}/link.exe\"" - AC_SUBST(CELIB_DIR) else RC="rc" lflags="${lflags} -nologo" @@ -1412,13 +1311,8 @@ # This essentially turns it all on. LDFLAGS_DEBUG="-debug -debugtype:cv" LDFLAGS_OPTIMIZE="-release" - if test "$doWince" != "no" ; then - LDFLAGS_CONSOLE="-link ${lflags}" - LDFLAGS_WINDOW=${LDFLAGS_CONSOLE} - else - LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}" - LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}" - fi + LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}" + LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}" fi SHLIB_SUFFIX=".dll" @@ -1427,7 +1321,7 @@ TCL_LIB_VERSIONS_OK=nodots ;; AIX-*) - AS_IF([test "${TCL_THREADS}" = "1" -a "$GCC" != "yes"], [ + AS_IF([test "$GCC" != "yes"], [ # AIX requires the _r compiler when gcc isn't being used case "${CC}" in *_r|*_r\ *) @@ -1493,6 +1387,13 @@ #----------------------------------------------------------- AC_CHECK_LIB(bind, inet_ntoa, [LIBS="$LIBS -lbind -lsocket"]) ;; + BSD/OS-2.1*|BSD/OS-3*) + SHLIB_CFLAGS="" + SHLIB_LD="shlicc -r" + SHLIB_SUFFIX=".so" + CC_SEARCH_FLAGS="" + LD_SEARCH_FLAGS="" + ;; BSD/OS-4.*) SHLIB_CFLAGS="-export-dynamic -fPIC" SHLIB_LD='${CC} -shared' @@ -1504,13 +1405,34 @@ CYGWIN_*) SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' - SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$[@].a" SHLIB_SUFFIX=".dll" + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$[@].a" + AC_CACHE_CHECK(for Cygwin version of gcc, + ac_cv_cygwin, + AC_TRY_COMPILE([ + #ifdef __CYGWIN__ + #error cygwin + #endif + ], [], + ac_cv_cygwin=no, + ac_cv_cygwin=yes) + ) + if test "$ac_cv_cygwin" = "no"; then + AC_MSG_ERROR([${CC} is not a cygwin compiler.]) + fi EXEEXT=".exe" do64bit_ok=yes CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; + dgux*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD='${CC} -G' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + CC_SEARCH_FLAGS="" + LD_SEARCH_FLAGS="" + ;; Haiku*) LDFLAGS="$LDFLAGS -Wl,--export-dynamic" SHLIB_CFLAGS="-fPIC" @@ -1527,15 +1449,13 @@ AS_IF([test "`uname -m`" = ia64], [ SHLIB_SUFFIX=".so" - # Use newer C++ library for C++ extensions - #if test "$GCC" != "yes" ; then - # CPPFLAGS="-AA" - #fi ], [ SHLIB_SUFFIX=".sl" ]) AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) AS_IF([test "$tcl_ok" = yes], [ + SHLIB_CFLAGS="+z" + SHLIB_LD="ld -b" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' @@ -1546,10 +1466,6 @@ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ], [ CFLAGS="$CFLAGS -z" - # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc - #CFLAGS="$CFLAGS +DAportable" - SHLIB_CFLAGS="+z" - SHLIB_LD="ld -b" ]) # Check to enable 64-bit flags for compiler/linker @@ -1574,6 +1490,27 @@ LDFLAGS_ARCH="+DD64" ]) ]) ;; + HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) + SHLIB_SUFFIX=".sl" + AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) + AS_IF([test "$tcl_ok" = yes], [ + SHLIB_CFLAGS="+z" + SHLIB_LD="ld -b" + SHLIB_LD_LIBS="" + LDFLAGS="$LDFLAGS -Wl,-E" + CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' + LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' + LD_LIBRARY_PATH_VAR="SHLIB_PATH" + ]) ;; + IRIX-5.*) + SHLIB_CFLAGS="" + SHLIB_LD="ld -shared -rdata_shared" + SHLIB_SUFFIX=".so" + AC_LIBOBJ(mkstemp) + AS_IF([test $doRpath = yes], [ + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) + ;; IRIX-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" @@ -1680,12 +1617,10 @@ SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so${SHLIB_VERSION}' LDFLAGS="-Wl,-export-dynamic" CFLAGS_OPTIMIZE="-O2" - AS_IF([test "${TCL_THREADS}" = "1"], [ - # On OpenBSD: Compile with -pthread - # Don't link with -lpthread - LIBS=`echo $LIBS | sed s/-lpthread//` - CFLAGS="$CFLAGS -pthread" - ]) + # On OpenBSD: Compile with -pthread + # Don't link with -lpthread + LIBS=`echo $LIBS | sed s/-lpthread//` + CFLAGS="$CFLAGS -pthread" # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots @@ -1699,14 +1634,12 @@ AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - AS_IF([test "${TCL_THREADS}" = "1"], [ - # The -pthread needs to go in the CFLAGS, not LIBS - LIBS=`echo $LIBS | sed s/-pthread//` - CFLAGS="$CFLAGS -pthread" - LDFLAGS="$LDFLAGS -pthread" - ]) + # The -pthread needs to go in the CFLAGS, not LIBS + LIBS=`echo $LIBS | sed s/-pthread//` + CFLAGS="$CFLAGS -pthread" + LDFLAGS="$LDFLAGS -pthread" ;; - FreeBSD-*) + DragonFly-*|FreeBSD-*) # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" @@ -1716,11 +1649,10 @@ AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) - AS_IF([test "${TCL_THREADS}" = "1"], [ - # The -pthread needs to go in the LDFLAGS, not LIBS - LIBS=`echo $LIBS | sed s/-pthread//` - CFLAGS="$CFLAGS $PTHREAD_CFLAGS" - LDFLAGS="$LDFLAGS $PTHREAD_LIBS"]) + # The -pthread needs to go in the LDFLAGS, not LIBS + LIBS=`echo $LIBS | sed s/-pthread//` + CFLAGS="$CFLAGS $PTHREAD_CFLAGS" + LDFLAGS="$LDFLAGS $PTHREAD_LIBS" case $system in FreeBSD-3.*) # Version numbers are dot-stripped by system policy. @@ -1792,10 +1724,6 @@ vers=`echo ${PACKAGE_VERSION} | sed -e 's/^\([[0-9]]\{1,5\}\)\(\(\.[[0-9]]\{1,3\}\)\{0,2\}\).*$/\1\2/p' -e d` SHLIB_LD="${SHLIB_LD} -current_version ${vers:-0} -compatibility_version ${vers:-0}" SHLIB_SUFFIX=".dylib" - # Don't use -prebind when building for Mac OS X 10.4 or later only: - AS_IF([test "`echo "${MACOSX_DEPLOYMENT_TARGET}" | awk -F '10\\.' '{print int([$]2)}'`" -lt 4 -a \ - "`echo "${CPPFLAGS}" | awk -F '-mmacosx-version-min=10\\.' '{print int([$]2)}'`" -lt 4], [ - LDFLAGS="$LDFLAGS -prebind"]) LDFLAGS="$LDFLAGS -headerpad_max_install_names" AC_CACHE_CHECK([if ld accepts -search_paths_first flag], tcl_cv_ld_search_paths_first, [ @@ -1873,16 +1801,14 @@ AS_IF([test "$GCC" = yes], [CFLAGS="$CFLAGS -mieee"], [ CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"]) # see pthread_intro(3) for pthread support on osf1, k.furukawa - AS_IF([test "${TCL_THREADS}" = 1], [ - CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" - CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" - LIBS=`echo $LIBS | sed s/-lpthreads//` - AS_IF([test "$GCC" = yes], [ - LIBS="$LIBS -lpthread -lmach -lexc" - ], [ - CFLAGS="$CFLAGS -pthread" - LDFLAGS="$LDFLAGS -pthread" - ]) + CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" + CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" + LIBS=`echo $LIBS | sed s/-lpthreads//` + AS_IF([test "$GCC" = yes], [ + LIBS="$LIBS -lpthread -lmach -lexc" + ], [ + CFLAGS="$CFLAGS -pthread" + LDFLAGS="$LDFLAGS -pthread" ]) ;; QNX-6*) @@ -2066,9 +1992,9 @@ case $system in AIX-*) ;; BSD/OS*) ;; - CYGWIN_*|MINGW32_*|MINGW64_*) ;; + CYGWIN_*|MINGW32_*|MINGW64_*|MSYS_*) ;; IRIX*) ;; - NetBSD-*|FreeBSD-*|OpenBSD-*) ;; + NetBSD-*|DragonFly-*|FreeBSD-*|OpenBSD-*) ;; Darwin-*) ;; SCO_SV-3.2*) ;; windows) ;; @@ -2182,6 +2108,8 @@ [Defined when compiler supports casting to union type.]) fi + AC_CHECK_HEADER(stdbool.h, [AC_DEFINE(HAVE_STDBOOL_H, 1, [Do we have ?])],) + AC_SUBST(CFLAGS_DEBUG) AC_SUBST(CFLAGS_OPTIMIZE) AC_SUBST(CFLAGS_WARNING) @@ -2630,9 +2558,10 @@ # Might define the following vars: # TCL_WIDE_INT_IS_LONG # TCL_WIDE_INT_TYPE -# HAVE_STRUCT_DIRENT64 +# HAVE_STRUCT_DIRENT64, HAVE_DIR64 # HAVE_STRUCT_STAT64 # HAVE_TYPE_OFF64_T +# #-------------------------------------------------------------------- AC_DEFUN([TEA_TCL_64BIT_FLAGS], [ @@ -2642,15 +2571,15 @@ # See if the compiler knows natively about __int64 AC_TRY_COMPILE(,[__int64 value = (__int64) 0;], tcl_type_64bit=__int64, tcl_type_64bit="long long") - # See if we should use long anyway Note that we substitute in the + # See if we could use long anyway Note that we substitute in the # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... AC_TRY_COMPILE(,[switch (0) { case 1: case (sizeof(]${tcl_type_64bit}[)==sizeof(long)): ; }],tcl_cv_type_64bit=${tcl_type_64bit})]) if test "${tcl_cv_type_64bit}" = none ; then - AC_DEFINE(TCL_WIDE_INT_IS_LONG, 1, [Are wide integers to be implemented with C 'long's?]) - AC_MSG_RESULT([using long]) + AC_DEFINE(TCL_WIDE_INT_IS_LONG, 1, [Do 'long' and 'long long' have the same size (64-bit)?]) + AC_MSG_RESULT([yes]) elif test "${tcl_cv_type_64bit}" = "__int64" \ -a "${TEA_PLATFORM}" = "windows" ; then # TEA specific: We actually want to use the default tcl.h checks in @@ -2670,6 +2599,15 @@ AC_DEFINE(HAVE_STRUCT_DIRENT64, 1, [Is 'struct dirent64' in ?]) fi + AC_CACHE_CHECK([for DIR64], tcl_cv_DIR64,[ + AC_TRY_COMPILE([#include +#include ],[struct dirent64 *p; DIR64 d = opendir64("."); + p = readdir64(d); rewinddir64(d); closedir64(d);], + tcl_cv_DIR64=yes,tcl_cv_DIR64=no)]) + if test "x${tcl_cv_DIR64}" = "xyes" ; then + AC_DEFINE(HAVE_DIR64, 1, [Is 'DIR64' in ?]) + fi + AC_CACHE_CHECK([for struct stat64], tcl_cv_struct_stat64,[ AC_TRY_COMPILE([#include ],[struct stat64 p; ], @@ -2748,7 +2686,7 @@ fi case "`uname -s`" in - *win32*|*WIN32*|*MINGW32_*|*MINGW64_*) + *win32*|*WIN32*|*MINGW32_*|*MINGW64_*|*MSYS_*) AC_CHECK_PROG(CYGPATH, cygpath, cygpath -m, echo) EXEEXT=".exe" TEA_PLATFORM="windows" @@ -3967,73 +3905,6 @@ #------------------------------------------------------------------------ -# TEA_PATH_CELIB -- -# -# Locate Keuchel's celib emulation layer for targeting Win/CE -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --with-celib=... -# -# Defines the following vars: -# CELIB_DIR Full path to the directory containing -# the include and platform lib files -#------------------------------------------------------------------------ - -AC_DEFUN([TEA_PATH_CELIB], [ - # First, look for one uninstalled. - # the alternative search directory is invoked by --with-celib - - if test x"${no_celib}" = x ; then - # we reset no_celib in case something fails here - no_celib=true - AC_ARG_WITH(celib,[ --with-celib=DIR use Windows/CE support library from DIR], with_celibconfig=${withval}) - AC_MSG_CHECKING([for Windows/CE celib directory]) - AC_CACHE_VAL(ac_cv_c_celibconfig,[ - # First check to see if --with-celibconfig was specified. - if test x"${with_celibconfig}" != x ; then - if test -d "${with_celibconfig}/inc" ; then - ac_cv_c_celibconfig=`(cd ${with_celibconfig}; pwd)` - else - AC_MSG_ERROR([${with_celibconfig} directory doesn't contain inc directory]) - fi - fi - - # then check for a celib library - if test x"${ac_cv_c_celibconfig}" = x ; then - for i in \ - ../celib-palm-3.0 \ - ../celib \ - ../../celib-palm-3.0 \ - ../../celib \ - `ls -dr ../celib-*3.[[0-9]]* 2>/dev/null` \ - ${srcdir}/../celib-palm-3.0 \ - ${srcdir}/../celib \ - `ls -dr ${srcdir}/../celib-*3.[[0-9]]* 2>/dev/null` \ - ; do - if test -d "$i/inc" ; then - ac_cv_c_celibconfig=`(cd $i; pwd)` - break - fi - done - fi - ]) - if test x"${ac_cv_c_celibconfig}" = x ; then - AC_MSG_ERROR([Cannot find celib support library directory]) - else - no_celib= - CELIB_DIR=${ac_cv_c_celibconfig} - CELIB_DIR=`echo "$CELIB_DIR" | sed -e 's!\\\!/!g'` - AC_MSG_RESULT([found $CELIB_DIR]) - fi - fi -]) - -#------------------------------------------------------------------------ # TEA_INSTALLER -- # # Configure the installer. diff -Nru itcl4-4.1.2/tests/all.tcl itcl4-4.2.0/tests/all.tcl --- itcl4-4.1.2/tests/all.tcl 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/tests/all.tcl 2019-10-04 16:02:02.000000000 +0000 @@ -7,12 +7,25 @@ # Copyright (c) 1998-2000 by Ajuba Solutions # All rights reserved. +if {"-testdir" ni $argv} { + lappend argv -testdir [file dir [info script]] +} + +if {[namespace which -command memory] ne "" && "-loadfile" ni $argv} { + puts "Tests running in sub-interpreters of leaktest circuit" + # -loadfile overwrites -load, so save it for helper in ::env(TESTFLAGS): + if {![info exists ::env(TESTFLAGS)] && [llength $argv]} { + set ::env(TESTFLAGS) $argv + } + lappend argv -loadfile [file join [file dirname [info script]] helpers.tcl] +} + package prefer latest -package require Tcl 8.6 +package require Tcl 8.6- package require tcltest 2.2 -tcltest::configure {*}$argv -testdir [file dir [info script]] +tcltest::configure {*}$argv tcltest::runAllTests return diff -Nru itcl4-4.1.2/tests/basic.test itcl4-4.2.0/tests/basic.test --- itcl4-4.1.2/tests/basic.test 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/tests/basic.test 2019-11-05 14:34:35.000000000 +0000 @@ -32,6 +32,9 @@ eval configure $args } destructor { + if {![info exists num]} { + lappend ::tcltest::itcl_basic_errors "unexpected: common deleted before destructor got called" + } incr num -1 } @@ -71,6 +74,11 @@ Counter c } +proc check_itcl_basic_errors {} { + if {[info exists ::tcltest::itcl_basic_errors] && [llength $::tcltest::itcl_basic_errors]} { + error "following errors occurs during tests:\n [join $::tcltest::itcl_basic_errors "\n "]" + } +} test basic-1.1 {define a simple class } -setup $setup -body { @@ -129,7 +137,7 @@ test basic-1.10 {objects can be destroyed by deleting their access command } -setup $setup2 -body { - rename ::x {} + rename ::x {} itcl::find objects x } -cleanup $cleanup2 -result {} @@ -187,8 +195,6 @@ ::itcl::delete class \u6210bcd } -result {bar} - - # ---------------------------------------------------------------------- # #auto names # ---------------------------------------------------------------------- @@ -344,6 +350,32 @@ [lsort [itcl::find objects counter*]] } -result {{counter0 counter1} {} {}} +check_itcl_basic_errors + +test basic-4.7 {clean-up of internal facilities +} -setup $setup4 -body { + # check callbacks are called if class gets removed using all possible ways: + # objects are properly destroyed, + # callback removing the namespace for the common private and protected variables + # (in ITCL_VARIABLES_NAMESPACE) is called, etc + set ::tcltest::itcl_basic_errors {} + set ivns ::itcl::internal::variables[namespace which Counter] + set result {} + lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}] + eval $cleanup + lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}] + eval $setup4 + lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}] + rename Counter {} + lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}] + eval $setup4 + lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}] + namespace delete Counter + lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}] + lappend result {*}$::tcltest::itcl_basic_errors +} -cleanup { + unset -nocomplain ivns ::tcltest::itcl_basic_errors +} -result [lrepeat 3 1 1 0 0] # ---------------------------------------------------------------------- # Namespace variables @@ -507,10 +539,59 @@ test_arrays0 do set undefined "scalar" } -result {scalar} -if {[namespace which [namespace current]::test:arrays] ne {}} { - ::itcl::delete class test_arrays +proc testVarResolver {{access private} {init 0}} { + eval [string map [list \$access $access \$init $init] { + itcl::class A { + $access common cv "A::cv" + public proc cv {} {set cv} + } + itcl::class B { + inherit A + public common res {} + lappend res [info exists cv] + if {$init} { + $access common cv "" + } else { + $access common cv + } + lappend res [info exists cv] + lappend cv "B::cv-add" + public proc cv {} {set cv} + } + lappend B::res [A::cv] [B::cv] + set B::res + }] +} +test basic-7.1-a {variable lookup before a common creation (bug [777ae99cfb])} -body { + # private uninitialized var: + testVarResolver private 0 +} -result {0 0 A::cv B::cv-add} -cleanup { + itcl::delete class B A +} +test basic-7.1-b {variable lookup before a common creation (bug [777ae99cfb])} -body { + # public uninitialized var: + testVarResolver public 0 +} -result {1 0 A::cv B::cv-add} -cleanup { + itcl::delete class B A +} +test basic-7.2-a {variable lookup before a common creation (bug [777ae99cfb])} -body { + # private initialized var: + testVarResolver private 1 +} -result {0 1 A::cv B::cv-add} -cleanup { + itcl::delete class B A +} +test basic-7.2-b {variable lookup before a common creation (bug [777ae99cfb])} -body { + # public initialized var: + testVarResolver public 1 +} -result {1 1 A::cv B::cv-add} -cleanup { + itcl::delete class B A } +if {[namespace which test_arrays] ne {}} { + ::itcl::delete class test_arrays +} +check_itcl_basic_errors +rename check_itcl_basic_errors {} ::tcltest::cleanupTests return diff -Nru itcl4-4.1.2/tests/body.test itcl4-4.2.0/tests/body.test --- itcl4-4.1.2/tests/body.test 2017-12-08 13:09:27.000000000 +0000 +++ itcl4-4.2.0/tests/body.test 2019-10-04 16:02:02.000000000 +0000 @@ -226,7 +226,7 @@ D d2 set ::answer } -cleanup { - itcl::delete class B + itcl::delete class B unset -nocomplain answer } -result {B A B D} diff -Nru itcl4-4.1.2/tests/ensemble.test itcl4-4.2.0/tests/ensemble.test --- itcl4-4.1.2/tests/ensemble.test 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/tests/ensemble.test 2019-10-04 16:02:02.000000000 +0000 @@ -208,6 +208,8 @@ test_numbers two x y ...and others described on the man page}} +::itcl::delete ensemble test_numbers + test ensemble-4.0 {SF Bug 119} -setup { itcl::ensemble foo part sub {} {error bar} } -cleanup { @@ -218,7 +220,6 @@ dict get $o -errorinfo } -match glob -result {*itcl ensemble part*} -::itcl::delete ensemble test_numbers ::tcltest::cleanupTests return diff -Nru itcl4-4.1.2/tests/helpers.tcl itcl4-4.2.0/tests/helpers.tcl --- itcl4-4.1.2/tests/helpers.tcl 1970-01-01 00:00:00.000000000 +0000 +++ itcl4-4.2.0/tests/helpers.tcl 2019-10-04 16:02:02.000000000 +0000 @@ -0,0 +1,48 @@ +# helpers.tcl -- +# +# This file contains helper scripts for all tests, like a mem-leak checker, etc. + +# -loadfile overwrites -load, so restore it from ::env(TESTFLAGS): +if {[info exists ::env(TESTFLAGS)]} { + array set testargs $::env(TESTFLAGS) + if {[info exists ::testargs(-load)]} { + eval $::testargs(-load) + } + unset testargs +} + +package require itcl + +if {[namespace which -command memory] ne "" && ( + ![info exists ::tcl::inl_mem_test] || $::tcl::inl_mem_test + ) +} { + proc getbytes {} {lindex [split [memory info] \n] 3 3} + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } + proc itcl_leaktest {testfile} { + set leak [leaktest [string map [list \ + @test@ $testfile \ + @testargv@ [if {[info exists ::argv]} {list tcltest::configure {*}$::argv}] + ] { + interp create i + load {} Itcl i + i eval {set ::tcl::inl_mem_test 0} + i eval {package require tcltest; @testargv@} + i eval [list source @test@] + interp delete i + }]] + if {$leak} { + puts "LEAKED: $leak bytes" + } + } + itcl_leaktest [info script] + return -code return +} diff -Nru itcl4-4.1.2/tests/import.test itcl4-4.2.0/tests/import.test --- itcl4-4.1.2/tests/import.test 2016-02-18 14:37:00.000000000 +0000 +++ itcl4-4.2.0/tests/import.test 2019-10-04 16:02:02.000000000 +0000 @@ -43,6 +43,7 @@ } {1 {wrong # args: should be "itcl::import::stub exists name"} 1 {wrong # args: should be "itcl::import::stub exists name"}} set interp [interp create] +$interp eval {set ::tcl::inl_mem_test 0} $interp eval " [list ::load $::itcllib itcl] [::tcltest::configure -load] @@ -92,6 +93,7 @@ # Test "itcl::import::stub" command # ---------------------------------------------------------------------- set interp [interp create] +$interp eval {set ::tcl::inl_mem_test 0} $interp eval " [list ::load $::itcllib itcl] [::tcltest::configure -load] diff -Nru itcl4-4.1.2/tests/info.test itcl4-4.2.0/tests/info.test --- itcl4-4.1.2/tests/info.test 2017-12-08 13:09:27.000000000 +0000 +++ itcl4-4.2.0/tests/info.test 2019-11-03 02:24:15.000000000 +0000 @@ -74,7 +74,7 @@ info function ?name? ?-protection? ?-type? ?-name? ?-args? ?-body? info heritage info inherit - info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? + info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope? ...and others described on the man page}} test info-1.3 {info: errors trigger usage info} { @@ -87,7 +87,7 @@ info function ?name? ?-protection? ?-type? ?-name? ?-args? ?-body? info heritage info inherit - info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? + info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope? ...and others described on the man page}} test info-1.4 {info: info class works on class itself} { @@ -105,38 +105,41 @@ ti info variable pubv } {public variable ::test_info::pubv public {set pubv "public: $pubv"} new-public} -test info-2.2b {info: public variables} { +test info-2.2b {info: public variables} -body { list [ti info variable pubv -protection] \ [ti info variable pubv -type] \ [ti info variable pubv -name] \ [ti info variable pubv -init] \ [ti info variable pubv -config] \ [ti info variable pubv -value] \ -} {public variable ::test_info::pubv public {set pubv "public: $pubv"} new-public} + [ti info variable pubv -scope] \ +} -match glob -result {public variable ::test_info::pubv public {set pubv "public: $pubv"} new-public ::itcl::internal::variables::oo::Obj*::test_info::pubv} test info-2.3a {info: protected variables} { ti info variable prov } {protected variable ::test_info::prov protected new-protected} -test info-2.3b {info: protected variables} { +test info-2.3b {info: protected variables} -body { list [ti info variable prov -protection] \ [ti info variable prov -type] \ [ti info variable prov -name] \ [ti info variable prov -init] \ [ti info variable prov -value] \ -} {protected variable ::test_info::prov protected new-protected} + [ti info variable prov -scope] \ +} -match glob -result {protected variable ::test_info::prov protected new-protected ::itcl::internal::variables::oo::Obj*::test_info::prov} test info-2.4a {info: private variables} { ti info variable priv } {private variable ::test_info::priv private new-private} -test info-2.4b {info: private variables} { +test info-2.4b {info: private variables} -body { list [ti info variable priv -protection] \ [ti info variable priv -type] \ [ti info variable priv -name] \ [ti info variable priv -init] \ [ti info variable priv -value] \ -} {private variable ::test_info::priv private new-private} + [ti info variable priv -scope] \ +} -match glob -result {private variable ::test_info::priv private new-private ::itcl::internal::variables::oo::Obj*::test_info::priv} test info-2.5 {"this" variable is built in} { ti info variable this @@ -164,7 +167,8 @@ [ti info variable pubc -name] \ [ti info variable pubc -init] \ [ti info variable pubc -value] \ -} {public common ::test_info::pubc public new-public} + [ti info variable pubc -scope] \ +} {public common ::test_info::pubc public new-public ::test_info::pubc} test info-2.10a {info: protected common variables} { ti info variable proc @@ -176,7 +180,8 @@ [ti info variable proc -name] \ [ti info variable proc -init] \ [ti info variable proc -value] \ -} {protected common ::test_info::proc protected new-protected} + [ti info variable proc -scope] \ +} {protected common ::test_info::proc protected new-protected ::itcl::internal::variables::test_info::proc} test info-2.11a {info: private common variables} { ti info variable pric @@ -188,7 +193,8 @@ [ti info variable pric -name] \ [ti info variable pric -init] \ [ti info variable pric -value] \ -} {private common ::test_info::pric private new-private} + [ti info variable pric -scope] \ +} {private common ::test_info::pric private new-private ::itcl::internal::variables::test_info::pric} test info-2.12 {info: public/protected/private vars have no "config" code} { list [ti info variable pubc -config] \ @@ -212,7 +218,7 @@ test info-2.16 {flag syntax errors} { list [catch {ti info variable defv -xyzzy} msg] $msg -} {1 {bad option "-xyzzy": must be -config, -init, -name, -protection, -type, or -value}} +} {1 {bad option "-xyzzy": must be -config, -init, -name, -protection, -type, -value, or -scope}} # ---------------------------------------------------------------------- # Member functions diff -Nru itcl4-4.1.2/tests/inherit.test itcl4-4.2.0/tests/inherit.test --- itcl4-4.1.2/tests/inherit.test 2016-01-28 17:52:30.000000000 +0000 +++ itcl4-4.2.0/tests/inherit.test 2019-10-04 16:02:02.000000000 +0000 @@ -162,6 +162,8 @@ "itcl::delete object mongrel1"} {{mongrel destruct} {foobar destruct} {foo destruct}} mongrel1} test inherit-1.10 {errors during destruction prevent class delete} { + itcl::body test_cd_bar::destructor {} {error "bar: failed"} + test_cd_mongrel mongrel2 xxx list [catch {itcl::delete class test_cd_foo} msg] $msg } {1 {bar: failed}} diff -Nru itcl4-4.1.2/tests/mkindex.test itcl4-4.2.0/tests/mkindex.test --- itcl4-4.1.2/tests/mkindex.test 2012-12-07 20:54:01.000000000 +0000 +++ itcl4-4.2.0/tests/mkindex.test 2019-10-04 16:02:02.000000000 +0000 @@ -13,6 +13,7 @@ package require tcltest 2.1 namespace import ::tcltest::test +set ::tcl::inl_mem_test 0 ::tcltest::loadTestedCommands package require itcl diff -Nru itcl4-4.1.2/tests/namespace.test itcl4-4.2.0/tests/namespace.test --- itcl4-4.1.2/tests/namespace.test 2016-01-28 17:49:11.000000000 +0000 +++ itcl4-4.2.0/tests/namespace.test 2019-10-04 16:02:02.000000000 +0000 @@ -41,7 +41,7 @@ if {$num == 0} { set num 1 } else { - set num [expr $num*$by] + set num [expr {$num*$by}] } } method do {args} { diff -Nru itcl4-4.1.2/tests/scope.test itcl4-4.2.0/tests/scope.test --- itcl4-4.1.2/tests/scope.test 2017-12-08 13:09:27.000000000 +0000 +++ itcl4-4.2.0/tests/scope.test 2019-10-04 16:02:02.000000000 +0000 @@ -89,7 +89,6 @@ test scope-2.9 {"--" terminates switches} { list [catch {itcl::code -namespace test_scope_ns -foo -bar} msg] $msg \ [catch {itcl::code -namespace test_scope_ns -- -foo -bar} msg] $msg - } {1 {bad option "-foo": should be -namespace or --} 0 {namespace inscope ::test_scope_ns {-foo -bar}}} namespace delete test_scope_ns diff -Nru itcl4-4.1.2/tests/sfbugs.test itcl4-4.2.0/tests/sfbugs.test --- itcl4-4.1.2/tests/sfbugs.test 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/tests/sfbugs.test 2019-11-03 02:24:15.000000000 +0000 @@ -271,18 +271,79 @@ } -result {{foo0 kerplunk hello world} {foo0 kerplunk hello world} {foo0 kerplunk hello world}} \ -cleanup {::itcl::delete class foo} -test sfbug-254 { SF bug #254 +test sfbug-254.1 { SF bug #254 + bug [1dc2d851eb] } -body { set interp [interp create] + set ::test_status "" + $interp eval { + oo::class destroy + } + lappend ::test_status "::oo::class destroy worked" + if {[catch { + $interp eval [::tcltest::loadScript] + $interp eval { + package require itcl + } + } msg]} { + lappend ::test_status $msg + } +} -result {{::oo::class destroy worked} {::oo::class does not refer to an object}} \ + -cleanup {interp delete $interp} + +test sfbug-254.2 { SF bug #254 + bug [1dc2d851eb] +} -body { + set interp [interp create] + set ::test_status "" + $interp eval {set ::tcl::inl_mem_test 0} + $interp eval [::tcltest::loadScript] $interp eval { package require itcl - set ::test_status "" oo::class destroy - lappend ::test_status "::oo::class destroy worked" } -} -result {{::oo::class destroy worked}} \ - -cleanup { } + lappend ::test_status "::oo::class destroy worked" + if {[catch { + $interp eval { + ::itcl::class ::test {} + } + } msg]} { + lappend ::test_status $msg + } +} -result {{::oo::class destroy worked} {oo-subsystem is deleted}} \ + -cleanup {interp delete $interp} + +test sfbug-254.3 { delete oo-subsystem should remove all classes + summary of bug [1dc2d851eb] +} -body { + set interp [interp create] + set ::test_status "" + $interp eval {set ::tcl::inl_mem_test 0} + $interp eval [::tcltest::loadScript] + $interp eval { + package require itcl + + ::itcl::class ::test {} + } + lappend ::test_status "::test class created" + $interp eval { + oo::class destroy + } + lappend ::test_status "::oo::class destroy worked" + if {[catch { + $interp eval { + ::test x + } + } msg]} { + lappend ::test_status $msg + } + if {[catch { + $interp eval { + ::itcl::class ::test2 {inherit ::test} + } + } msg]} { + lappend ::test_status $msg + } +} -result {{::test class created} {::oo::class destroy worked} {invalid command name "::test"} {oo-subsystem is deleted}} \ + -cleanup {interp delete $interp} test sfbug-255 { SF bug #255 } -body { @@ -367,6 +428,8 @@ test sfbug-257 { SF bug #257 } -body { set interp [interp create] + $interp eval {set ::tcl::inl_mem_test 0} + $interp eval [::tcltest::loadScript] $interp eval { package require itcl set ::test_status "" @@ -383,7 +446,7 @@ ::cl1::p1 $obj1 p1 $obj1 m1 - + catch { $obj1 m1 ::cl1::p1 @@ -581,6 +644,18 @@ itcl::delete class A B } -result {::b ::b} +test fossil-9.4 {9eea4912b9} -setup { + itcl::class A { + public method foo WRONG + } +} -body { + itcl::body A::foo {RIGHT} {} + A a + a info args foo +} -cleanup { + itcl::delete class A +} -result RIGHT + test sfbugs-281 {Resolve inherited common} -setup { itcl::class Parent {protected common x 0} } -cleanup { diff -Nru itcl4-4.1.2/tests/typeinfo.test itcl4-4.2.0/tests/typeinfo.test --- itcl4-4.1.2/tests/typeinfo.test 2012-11-05 12:53:12.000000000 +0000 +++ itcl4-4.2.0/tests/typeinfo.test 2019-11-03 02:24:15.000000000 +0000 @@ -52,7 +52,7 @@ info types ?pattern? info typevariable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? info typevars ?pattern? - info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? + info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope? info variables ?pattern? ...and others described on the man page} @@ -655,7 +655,7 @@ info types ?pattern? info typevariable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? info typevars ?pattern? - info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? + info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope? info variables ?pattern? ...and others described on the man page} diff -Nru itcl4-4.1.2/tests/widgetadaptor.test itcl4-4.2.0/tests/widgetadaptor.test --- itcl4-4.1.2/tests/widgetadaptor.test 2017-12-14 13:33:01.000000000 +0000 +++ itcl4-4.2.0/tests/widgetadaptor.test 2019-10-04 16:02:02.000000000 +0000 @@ -29,7 +29,7 @@ if {[package vsatisfies [package provide Tcl] ${version}-]} return puts " Aborting the tests found in \"[file tail [info script]]\"" - puts " Requiring at least Tcl $version, have [package present Tcl]." + puts " Requiring at least Tcl $version, have [package provide Tcl]." # This causes a 'return' in the calling scope. return -code return @@ -58,6 +58,7 @@ return } } elseif {[package vcompare [package present tcltest] $version] >= 0} { + namespace import -force ::tcltest::* return } @@ -503,7 +504,7 @@ test install-1.3 {can't install until hull exists } -constraints { - tk + tk } -body { widgetadaptor myframe { # Delegate an option just to make sure the component variable @@ -820,11 +821,5 @@ #--------------------------------------------------------------------- # Clean up -if {[llength [::info command ::itcl::dumppreserveinfo]] > 0} { - ::itcl::finish checkmemoryleaks - ::itcl::dumppreserveinfo - ::itcl::dumprefcountinfo -nodeleted -} - ::tcltest::cleanupTests return diff -Nru itcl4-4.1.2/tests/widgetclass.test itcl4-4.2.0/tests/widgetclass.test --- itcl4-4.1.2/tests/widgetclass.test 2017-12-14 13:33:01.000000000 +0000 +++ itcl4-4.2.0/tests/widgetclass.test 2019-10-04 16:02:02.000000000 +0000 @@ -29,7 +29,7 @@ if {[package vsatisfies [package provide Tcl] ${version}-]} return puts " Aborting the tests found in \"[file tail [info script]]\"" - puts " Requiring at least Tcl $version, have [package present Tcl]." + puts " Requiring at least Tcl $version, have [package provide Tcl]." # This causes a 'return' in the calling scope. return -code return @@ -58,6 +58,7 @@ return } } elseif {[package vcompare [package present tcltest] $version] >= 0} { + namespace import -force ::tcltest::* return } @@ -220,7 +221,7 @@ } constructor {args} { - installcomponent text using text $win.text + installcomponent text using text $win.text } } @@ -817,11 +818,5 @@ #--------------------------------------------------------------------- # Clean up -if {[llength [::info command ::itcl::dumppreserveinfo]] > 0} { - ::itcl::finish - ::itcl::dumppreserveinfo checkmemoryleaks - ::itcl::dumprefcountinfo -nodeleted -} - ::tcltest::cleanupTests return diff -Nru itcl4-4.1.2/tools/genStubs.tcl itcl4-4.2.0/tools/genStubs.tcl --- itcl4-4.1.2/tools/genStubs.tcl 2014-02-11 13:32:15.000000000 +0000 +++ itcl4-4.2.0/tools/genStubs.tcl 2019-10-04 16:02:02.000000000 +0000 @@ -502,7 +502,7 @@ } append line ", ...)" if {[lindex $args end] eq "{const char *} format"} { - append line " TCL_FORMAT_PRINTF(" [expr [llength $args] - 1] ", " [llength $args] ")" + append line " TCL_FORMAT_PRINTF(" [expr {[llength $args] - 1}] ", " [llength $args] ")" } } default { @@ -602,7 +602,7 @@ } append text ", ...)" if {[lindex $args end] eq "{const char *} format"} { - append text " TCL_FORMAT_PRINTF(" [expr [llength $args] - 1] ", " [llength $args] ")" + append text " TCL_FORMAT_PRINTF(" [expr {[llength $args] - 1}] ", " [llength $args] ")" } } default { diff -Nru itcl4-4.1.2/win/dllEntryPoint.c itcl4-4.2.0/win/dllEntryPoint.c --- itcl4-4.1.2/win/dllEntryPoint.c 2011-04-26 16:49:34.000000000 +0000 +++ itcl4-4.2.0/win/dllEntryPoint.c 2019-10-04 16:02:02.000000000 +0000 @@ -1,4 +1,4 @@ -/* +/* * dllEntryPoint.c -- * * This file implements the Dll entry point as needed by Windows. @@ -49,4 +49,4 @@ return TRUE; } -#endif \ No newline at end of file +#endif diff -Nru itcl4-4.1.2/win/makefile.vc itcl4-4.2.0/win/makefile.vc --- itcl4-4.1.2/win/makefile.vc 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/win/makefile.vc 2019-10-04 16:02:02.000000000 +0000 @@ -10,7 +10,7 @@ # For other build options (debug, static etc.) # See TIP 477 (https://core.tcl.tk/tips/doc/trunk/tip/477.md) for # detailed documentation. -# +# # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # @@ -19,9 +19,6 @@ PROJECT = itcl NEED_TCL_SOURCE = 1 RCFILE = itcl.rc -# Tcl 8.6 etc. compile with /DUNICODE. ITcl pre-nmake reform compiled -# without -DUNICODE. Keep that behaviour for now. -USE_WIDECHAR_API = 0 !include "rules-ext.vc" @@ -50,9 +47,9 @@ PRJ_STUBOBJS = $(TMP_DIR)\itclStubLib.obj -PRJ_DEFINES = -D_CRT_SECURE_NO_WARNINGS +PRJ_DEFINES = /D_CRT_SECURE_NO_WARNINGS !if $(DEBUG) -PRJ_DEFINES = $(PRJ_DEFINES) -DITCL_DEBUG +PRJ_DEFINES = $(PRJ_DEFINES) /DITCL_DEBUG !endif PRJ_HEADERS_PUBLIC = \ @@ -67,12 +64,12 @@ pkgindex: $(OUT_DIR)\pkgIndex.tcl $(OUT_DIR)\pkgIndex.tcl: @$(COPY) << "$(OUT_DIR)\pkgIndex.tcl" -if {[package vsatisfies 8.0 [package provide Tcl]]} { +if {[package vsatisfies 8.0 [package provide Tcl]]} { set add 80 } else { set add {t} } -if {[info exists ::tcl_platform(debug)] && $$::tcl_platform(debug) && \ +if {[::tcl::pkgconfig get debug] && \ [file exists [file join $$dir itcl$(VERSION)$${add}g.dll]]} { package ifneeded Itcl $(DOTVERSION) [list load [file join $$dir itcl$(VERSION)$${add}g.dll] Itcl] } else { diff -Nru itcl4-4.1.2/win/nmakehlp.c itcl4-4.2.0/win/nmakehlp.c --- itcl4-4.1.2/win/nmakehlp.c 2017-12-15 18:00:37.000000000 +0000 +++ itcl4-4.2.0/win/nmakehlp.c 2019-10-04 16:02:02.000000000 +0000 @@ -74,7 +74,7 @@ char msg[300]; DWORD dwWritten; int chars; - char *s; + const char *s; /* * Make sure children (cl.exe and link.exe) are kept quiet. @@ -739,7 +739,7 @@ #if 0 /* This function is not available in Visual C++ 6 */ /* * Use numerics 0 -> FindExInfoStandard, - * 1 -> FindExSearchLimitToDirectories, + * 1 -> FindExSearchLimitToDirectories, * as these are not defined in Visual C++ 6 */ hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0); @@ -754,7 +754,7 @@ do { int sublen; /* - * We need to check it is a directory despite the + * We need to check it is a directory despite the * FindExSearchLimitToDirectories in the above call. See SDK docs */ if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) @@ -785,15 +785,15 @@ * that is used to confirm it is the correct directory. * The search path for the package directory is currently only * the parent and grandparent of the current working directory. - * If found, the command prints + * If found, the command prints * name_DIRPATH= * and returns 0. If not found, does not print anything and returns 1. */ static int LocateDependency(const char *keypath) { int i, ret; - static char *paths[] = {"..", "..\\..", "..\\..\\.."}; - + static const char *paths[] = {"..", "..\\..", "..\\..\\.."}; + for (i = 0; i < (sizeof(paths)/sizeof(paths[0])); ++i) { ret = LocateDependencyHelper(paths[i], keypath); if (ret == 0) diff -Nru itcl4-4.1.2/win/rules.vc itcl4-4.2.0/win/rules.vc --- itcl4-4.1.2/win/rules.vc 2018-10-16 16:57:21.000000000 +0000 +++ itcl4-4.2.0/win/rules.vc 2019-10-04 16:02:02.000000000 +0000 @@ -24,7 +24,7 @@ # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 -RULES_VERSION_MINOR = 1 +RULES_VERSION_MINOR = 4 # The PROJECT macro must be defined by parent makefile. !if "$(PROJECT)" == "" @@ -162,7 +162,7 @@ # COMPATDIR - source directory that holds compatibility sources # DOCDIR - source directory containing documentation files # GENERICDIR - platform-independent source directory -# WINDIR - Windows-specific source directory +# WIN_DIR - Windows-specific source directory # TESTDIR - directory containing test files # TOOLSDIR - directory containing build tools # _TCLDIR - root of the Tcl installation OR the Tcl sources. Not set @@ -215,17 +215,15 @@ DEMODIR = $(ROOT)\demos !endif !endif # ifndef DEMODIR -# Do NOT enclose WINDIR in a !ifndef because Windows always defines -# WINDIR env var to point to c:\windows! -# TBD - This is a potentially dangerous conflict, rename WINDIR to -# something else -WINDIR = $(ROOT)\win +# Do NOT use WINDIR because it is Windows internal environment +# variable to point to c:\windows! +WIN_DIR = $(ROOT)\win !ifndef RCDIR -!if exist("$(WINDIR)\rc") -RCDIR = $(WINDIR)\rc +!if exist("$(WIN_DIR)\rc") +RCDIR = $(WIN_DIR)\rc !else -RCDIR = $(WINDIR) +RCDIR = $(WIN_DIR) !endif !endif RCDIR = $(RCDIR:/=\) @@ -393,8 +391,8 @@ !endif -# If INSTALLDIR set to tcl installation root dir then reset to the -# lib dir for installing extensions +# If INSTALLDIR set to Tcl installation root dir then reset to the +# lib dir for installing extensions !if exist("$(_INSTALLDIR)\include\tcl.h") _INSTALLDIR=$(_INSTALLDIR)\lib !endif @@ -475,6 +473,21 @@ MACHINE=$(ARCH) !endif +#--------------------------------------------------------------- +# The PLATFORM_IDENTIFY macro matches the values returned by +# the Tcl platform::identify command +!if "$(MACHINE)" == "AMD64" +PLATFORM_IDENTIFY = win32-x86_64 +!else +PLATFORM_IDENTIFY = win32-ix86 +!endif + +# The MULTIPLATFORM macro controls whether binary extensions are installed +# in platform-specific directories. Intended to be set/used by extensions. +!ifndef MULTIPLATFORM_INSTALL +MULTIPLATFORM_INSTALL = 0 +!endif + #------------------------------------------------------------ # Figure out the *host* architecture by reading the registry @@ -546,7 +559,7 @@ # The following macros are set: # OPTIMIZATIONS - the compiler flags to be used for optimized builds # DEBUGFLAGS - the compiler flags to be used for debug builds -# LINKERFLAGS - Flags passed to the linker +# LINKERFLAGS - Flags passed to the linker # # Note that these are the compiler settings *available*, not those # that will be *used*. The latter depends on the OPTS macro settings @@ -671,6 +684,8 @@ # USE_STUBS - 1 -> compile to use stubs interfaces, 0 -> direct linking # CONFIG_CHECK - 1 -> check current build configuration against Tcl # configuration (ignored for Tcl itself) +# _USE_64BIT_TIME_T - forces a build using 64-bit time_t for 32-bit build +# (CRT library should support this) # Further, LINKERFLAGS are modified based on above. # Default values for all the above @@ -732,13 +747,20 @@ !if [nmakehlp -f $(OPTS) "nothreads"] !message *** Compile explicitly for non-threaded tcl -TCL_THREADS = 0 +TCL_THREADS = 0 USE_THREAD_ALLOC= 0 !else TCL_THREADS = 1 USE_THREAD_ALLOC= 1 !endif +!if [nmakehlp -f $(OPTS) "time64bit"] +!message *** Force 64-bit time_t +_USE_64BIT_TIME_T = 1 +!endif + +# Yes, it's weird that the "symbols" option controls DEBUG and +# the "pdbs" option controls SYMBOLS. That's historical. !if [nmakehlp -f $(OPTS) "symbols"] !message *** Doing symbols DEBUG = 1 @@ -970,7 +992,7 @@ # different compilers, build configurations etc., # # Naming convention (suffixes): -# t = full thread support. +# t = full thread support. (Not used for Tcl >= 8.7) # s = static library (as opposed to an import library) # g = linked to the debug enabled C run-time. # x = special static build when it links to the dynamic C run-time. @@ -1028,7 +1050,7 @@ !endif !endif -!if !$(TCL_THREADS) +!if !$(TCL_THREADS) || $(TCL_VERSION) > 86 TMP_DIRFULL = $(TMP_DIRFULL:Threaded=) SUFX = $(SUFX:t=) !endif @@ -1061,7 +1083,7 @@ # Set up paths to various Tcl executables and libraries needed by extensions !if $(DOING_TCL) -TCLSHNAME = $(PROJECT)sh$(TCL_VERSION)$(SUFX).exe +TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe TCLSH = $(OUT_DIR)\$(TCLSHNAME) TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) @@ -1069,7 +1091,7 @@ TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) -TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" +TCL_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" !else # ! $(DOING_TCL) @@ -1078,20 +1100,17 @@ # When building extensions, we need to locate tclsh. Depending on version # of Tcl we are building against, this may or may not have a "t" suffix. # Try various possibilities in turn. -TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX).exe -!if !exist("$(TCLSH)") && $(TCL_THREADS) -TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX).exe -!endif +TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe !if !exist("$(TCLSH)") -TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe +TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX:t=).exe !endif TCLSTUBLIB = $(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib -TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib +TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX:t=).lib # When building extensions, may be linking against Tcl that does not add # "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. !if !exist("$(TCLIMPLIB)") -TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX:t=).lib +TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)t$(SUFX:t=).lib !endif TCL_LIBRARY = $(_TCLDIR)\lib TCLREGLIB = $(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib @@ -1101,19 +1120,16 @@ !else # Building against Tcl sources -TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX).exe -!if !exist($(TCLSH)) && $(TCL_THREADS) -TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX).exe -!endif -!if !exist($(TCLSH)) TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX:t=).exe +!if !exist($(TCLSH)) +TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX:t=).exe !endif TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib -TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib +TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX:t=).lib # When building extensions, may be linking against Tcl that does not add # "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. !if !exist("$(TCLIMPLIB)") -TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX:t=).lib +TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)t$(SUFX:t=).lib !endif TCL_LIBRARY = $(_TCLDIR)\library TCLREGLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib @@ -1150,7 +1166,7 @@ TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME) TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME) TKLIB = $(OUT_DIR)\$(TKLIBNAME) -TK_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" +TK_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" !else # effectively NEED_TK @@ -1209,7 +1225,7 @@ # SCRIPT_INSTALL_DIR - where scripts should be installed # INCLUDE_INSTALL_DIR - where C include files should be installed # DEMO_INSTALL_DIR - where demos should be installed -# PRJ_INSTALL_DIR - where package will be installed (not set for tcl and tk) +# PRJ_INSTALL_DIR - where package will be installed (not set for Tcl and Tk) !if $(DOING_TCL) || $(DOING_TK) LIB_INSTALL_DIR = $(_INSTALLDIR)\lib @@ -1226,12 +1242,17 @@ !else # extension other than Tk PRJ_INSTALL_DIR = $(_INSTALLDIR)\$(PROJECT)$(DOTVERSION) +!if $(MULTIPLATFORM_INSTALL) +LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR)\$(PLATFORM_IDENTIFY) +BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR)\$(PLATFORM_IDENTIFY) +!else LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR) BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR) +!endif DOC_INSTALL_DIR = $(PRJ_INSTALL_DIR) SCRIPT_INSTALL_DIR = $(PRJ_INSTALL_DIR) DEMO_INSTALL_DIR = $(PRJ_INSTALL_DIR)\demos -INCLUDE_INSTALL_DIR = $(_TCLDIR)\include +INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\..\include !endif @@ -1256,82 +1277,69 @@ # baselibs - minimum Windows libraries required. Parent makefile can # define PRJ_LIBS before including rules.rc if additional libs are needed -OPTDEFINES = -DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) -DSTDC_HEADERS +OPTDEFINES = /DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) /DSTDC_HEADERS !if $(TCL_MEM_DEBUG) -OPTDEFINES = $(OPTDEFINES) -DTCL_MEM_DEBUG +OPTDEFINES = $(OPTDEFINES) /DTCL_MEM_DEBUG !endif !if $(TCL_COMPILE_DEBUG) -OPTDEFINES = $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS +OPTDEFINES = $(OPTDEFINES) /DTCL_COMPILE_DEBUG /DTCL_COMPILE_STATS !endif -!if $(TCL_THREADS) -OPTDEFINES = $(OPTDEFINES) -DTCL_THREADS=1 -!if $(USE_THREAD_ALLOC) -OPTDEFINES = $(OPTDEFINES) -DUSE_THREAD_ALLOC=1 +!if $(TCL_THREADS) && $(TCL_VERSION) < 87 +OPTDEFINES = $(OPTDEFINES) /DTCL_THREADS=1 +!if $(USE_THREAD_ALLOC) && $(TCL_VERSION) < 87 +OPTDEFINES = $(OPTDEFINES) /DUSE_THREAD_ALLOC=1 !endif !endif !if $(STATIC_BUILD) -OPTDEFINES = $(OPTDEFINES) -DSTATIC_BUILD +OPTDEFINES = $(OPTDEFINES) /DSTATIC_BUILD !endif !if $(TCL_NO_DEPRECATED) -OPTDEFINES = $(OPTDEFINES) -DTCL_NO_DEPRECATED +OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED !endif !if $(USE_STUBS) # Note we do not define USE_TCL_STUBS even when building tk since some # test targets in tk do not use stubs !if ! $(DOING_TCL) -USE_STUBS_DEFS = -DUSE_TCL_STUBS -DUSE_TCLOO_STUBS +USE_STUBS_DEFS = /DUSE_TCL_STUBS /DUSE_TCLOO_STUBS !if $(NEED_TK) -USE_STUBS_DEFS = $(USE_STUBS_DEFS) -DUSE_TK_STUBS +USE_STUBS_DEFS = $(USE_STUBS_DEFS) /DUSE_TK_STUBS !endif !endif !endif # USE_STUBS !if !$(DEBUG) -OPTDEFINES = $(OPTDEFINES) -DNDEBUG +OPTDEFINES = $(OPTDEFINES) /DNDEBUG !if $(OPTIMIZING) -OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_OPTIMIZED +OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_OPTIMIZED !endif !endif !if $(PROFILE) -OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_PROFILED +OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_PROFILED !endif !if "$(MACHINE)" == "AMD64" -OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_DO64BIT +OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT !endif !if $(VCVERSION) < 1300 -OPTDEFINES = $(OPTDEFINES) -DNO_STRTOI64 +OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64 !endif -# _ATL_XP_TARGETING - Newer SDK's need this to build for XP -COMPILERFLAGS = /D_ATL_XP_TARGETING - -# Following is primarily for the benefit of extensions. Tcl 8.5 builds -# Tcl without /DUNICODE, while 8.6 builds with it defined. When building -# an extension, it is advisable (but not mandated) to use the same Windows -# API as the Tcl build. This is accordingly defaulted below. A particular -# extension can override this by pre-definining USE_WIDECHAR_API. -!ifndef USE_WIDECHAR_API -!if $(TCL_VERSION) > 85 -USE_WIDECHAR_API = 1 -!else -USE_WIDECHAR_API = 0 -!endif +!if "$(_USE_64BIT_TIME_T)" == "1" +OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T !endif -!if $(USE_WIDECHAR_API) -COMPILERFLAGS = $(COMPILERFLAGS) /DUNICODE /D_UNICODE -!endif +# _ATL_XP_TARGETING - Newer SDK's need this to build for XP +COMPILERFLAGS = /D_ATL_XP_TARGETING # Like the TEA system only set this non empty for non-Tk extensions # Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME # so we pass both !if !$(DOING_TCL) && !$(DOING_TK) -PKGNAMEFLAGS = -DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ - -DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ - -DPACKAGE_VERSION="\"$(DOTVERSION)\"" \ - -DMODULE_SCOPE=extern +PKGNAMEFLAGS = /DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ + /DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ + /DPACKAGE_VERSION="\"$(DOTVERSION)\"" \ + /DMODULE_SCOPE=extern !endif # crt picks the C run time based on selected OPTS @@ -1378,7 +1386,7 @@ ### Common compiler options that are architecture specific !if "$(MACHINE)" == "ARM" -carch = -D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE +carch = /D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE !else carch = !endif @@ -1390,7 +1398,7 @@ INCLUDES = $(TCL_INCLUDES) $(TK_INCLUDES) $(PRJ_INCLUDES) !if !$(DOING_TCL) && !$(DOING_TK) -INCLUDES = $(INCLUDES) -I"$(GENERICDIR)" -I"$(WINDIR)" -I"$(COMPATDIR)" +INCLUDES = $(INCLUDES) -I"$(GENERICDIR)" -I"$(WIN_DIR)" -I"$(COMPATDIR)" !endif # These flags are defined roughly in the order of the pre-reform @@ -1406,13 +1414,13 @@ # BUILD_$(PROJECT) macro which should be defined only for the shared # library *implementation* and not for its caller interface -appcflags = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES) $(USE_STUBS_DEFS) appcflags_nostubs = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES) -pkgcflags = $(appcflags) $(PKGNAMEFLAGS) -DBUILD_$(PROJECT) -pkgcflags_nostubs = $(appcflags_nostubs) $(PKGNAMEFLAGS) -DBUILD_$(PROJECT) +appcflags = $(appcflags_nostubs) $(USE_STUBS_DEFS) +pkgcflags = $(appcflags) $(PKGNAMEFLAGS) /DBUILD_$(PROJECT) +pkgcflags_nostubs = $(appcflags_nostubs) $(PKGNAMEFLAGS) /DBUILD_$(PROJECT) # stubscflags contains $(cflags) plus flags used for building a stubs -# library for the package. Note: -DSTATIC_BUILD is defined in +# library for the package. Note: /DSTATIC_BUILD is defined in # $(OPTDEFINES) only if the OPTS configuration indicates a static # library. However the stubs library is ALWAYS static hence included # here irrespective of the OPTS setting. @@ -1422,9 +1430,9 @@ # so we do not remove it from cflags. -GL may prevent extensions # compiled with one VC version to fail to link against stubs library # compiled with another VC version. Check for this and fix accordingly. -stubscflags = $(cflags) $(PKGNAMEFLAGS) $(PRJ_DEFINES) $(OPTDEFINES) -Zl -DSTATIC_BUILD $(INCLUDES) +stubscflags = $(cflags) $(PKGNAMEFLAGS) $(PRJ_DEFINES) $(OPTDEFINES) -Zl /DSTATIC_BUILD $(INCLUDES) $(USE_STUBS_DEFS) -# Link flags +# Link flags !if $(DEBUG) ldebug = -debug -debugtype:cv @@ -1440,7 +1448,7 @@ ldebug= $(ldebug) -profile !endif -### Declarations common to all linker versions +### Declarations common to all linker versions lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) !if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 @@ -1499,13 +1507,13 @@ GUIEXECMD = $(link32) $(guilflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ $(TCL_INCLUDES) \ - -DDEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ - -DCOMMAVERSION=$(DOTVERSION:.=,),0 \ - -DDOTVERSION=\"$(DOTVERSION)\" \ - -DVERSION=\"$(VERSION)\" \ - -DSUFX=\"$(SUFX)\" \ - -DPROJECT=\"$(PROJECT)\" \ - -DPRJLIBNAME=\"$(PRJLIBNAME)\" + /DDEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ + /DCOMMAVERSION=$(DOTVERSION:.=,),0 \ + /DDOTVERSION=\"$(DOTVERSION)\" \ + /DVERSION=\"$(VERSION)\" \ + /DSUFX=\"$(SUFX)\" \ + /DPROJECT=\"$(PROJECT)\" \ + /DPRJLIBNAME=\"$(PRJLIBNAME)\" !ifndef DEFAULT_BUILD_TARGET DEFAULT_BUILD_TARGET = $(PROJECT) @@ -1513,9 +1521,15 @@ default-target: $(DEFAULT_BUILD_TARGET) +!if $(MULTIPLATFORM_INSTALL) +default-pkgindex: + @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ + [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl +!else default-pkgindex: @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl +!endif default-pkgindex-tea: @if exist $(ROOT)\pkgIndex.tcl.in nmakehlp -s << $(ROOT)\pkgIndex.tcl.in > $(OUT_DIR)\pkgIndex.tcl @@ -1525,15 +1539,26 @@ @PKG_LIB_FILE@ $(PRJLIBNAME) << - default-install: default-install-binaries default-install-libraries +!if $(SYMBOLS) +default-install: default-install-pdbs +!endif +# Again to deal with historical brokenness, there is some confusion +# in terminlogy. For extensions, the "install-binaries" was used to +# locate target directory for *binary shared libraries* and thus +# the appropriate macro is LIB_INSTALL_DIR since BIN_INSTALL_DIR is +# for executables (exes). On the other hand the "install-libraries" +# target is for *scripts* and should have been called "install-scripts". default-install-binaries: $(PRJLIB) - @echo Installing binaries to '$(SCRIPT_INSTALL_DIR)' - @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)" - @$(CPY) $(PRJLIB) "$(SCRIPT_INSTALL_DIR)" >NUL + @echo Installing binaries to '$(LIB_INSTALL_DIR)' + @if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)" + @$(CPY) $(PRJLIB) "$(LIB_INSTALL_DIR)" >NUL -default-install-libraries: $(OUT_DIR)\pkgIndex.tcl +# Alias for default-install-scripts +default-install-libraries: default-install-scripts + +default-install-scripts: $(OUT_DIR)\pkgIndex.tcl @echo Installing libraries to '$(SCRIPT_INSTALL_DIR)' @if exist $(LIBDIR) $(CPY) $(LIBDIR)\*.tcl "$(SCRIPT_INSTALL_DIR)" @echo Installing package index in '$(SCRIPT_INSTALL_DIR)' @@ -1544,6 +1569,11 @@ @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)" @$(CPY) $(PRJSTUBLIB) "$(SCRIPT_INSTALL_DIR)" >NUL +default-install-pdbs: + @echo Installing PDBs to '$(LIB_INSTALL_DIR)' + @if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)" + @$(CPY) "$(OUT_DIR)\*.pdb" "$(LIB_INSTALL_DIR)\" + default-install-docs-html: @echo Installing documentation files to '$(DOC_INSTALL_DIR)' @if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)" @@ -1562,20 +1592,20 @@ default-clean: @echo Cleaning $(TMP_DIR)\* ... @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR) - @echo Cleaning $(WINDIR)\nmakehlp.obj, nmakehlp.exe ... - @if exist $(WINDIR)\nmakehlp.obj del $(WINDIR)\nmakehlp.obj - @if exist $(WINDIR)\nmakehlp.exe del $(WINDIR)\nmakehlp.exe - @if exist $(WINDIR)\nmakehlp.out del $(WINDIR)\nmakehlp.out - @echo Cleaning $(WINDIR)\nmhlp-out.txt ... - @if exist $(WINDIR)\nmhlp-out.txt del $(WINDIR)\nmhlp-out.txt - @echo Cleaning $(WINDIR)\_junk.pch ... - @if exist $(WINDIR)\_junk.pch del $(WINDIR)\_junk.pch - @echo Cleaning $(WINDIR)\vercl.x, vercl.i ... - @if exist $(WINDIR)\vercl.x del $(WINDIR)\vercl.x - @if exist $(WINDIR)\vercl.i del $(WINDIR)\vercl.i - @echo Cleaning $(WINDIR)\versions.vc, version.vc ... - @if exist $(WINDIR)\versions.vc del $(WINDIR)\versions.vc - @if exist $(WINDIR)\version.vc del $(WINDIR)\version.vc + @echo Cleaning $(WIN_DIR)\nmakehlp.obj, nmakehlp.exe ... + @if exist $(WIN_DIR)\nmakehlp.obj del $(WIN_DIR)\nmakehlp.obj + @if exist $(WIN_DIR)\nmakehlp.exe del $(WIN_DIR)\nmakehlp.exe + @if exist $(WIN_DIR)\nmakehlp.out del $(WIN_DIR)\nmakehlp.out + @echo Cleaning $(WIN_DIR)\nmhlp-out.txt ... + @if exist $(WIN_DIR)\nmhlp-out.txt del $(WIN_DIR)\nmhlp-out.txt + @echo Cleaning $(WIN_DIR)\_junk.pch ... + @if exist $(WIN_DIR)\_junk.pch del $(WIN_DIR)\_junk.pch + @echo Cleaning $(WIN_DIR)\vercl.x, vercl.i ... + @if exist $(WIN_DIR)\vercl.x del $(WIN_DIR)\vercl.x + @if exist $(WIN_DIR)\vercl.i del $(WIN_DIR)\vercl.i + @echo Cleaning $(WIN_DIR)\versions.vc, version.vc ... + @if exist $(WIN_DIR)\versions.vc del $(WIN_DIR)\versions.vc + @if exist $(WIN_DIR)\version.vc del $(WIN_DIR)\version.vc default-hose: default-clean @echo Hosing $(OUT_DIR)\* ... @@ -1602,7 +1632,7 @@ @if exist $(LIBDIR) for %f in ("$(LIBDIR)\*.tcl") do @$(COPY) %f "$(OUT_DIR)" $(DEBUGGER) $(TCLSH) -# Generation of Windows version resource +# Generation of Windows version resource !ifdef RCFILE # Note: don't use $** in below rule because there may be other dependencies @@ -1641,7 +1671,7 @@ VALUE "OriginalFilename", PRJLIBNAME VALUE "FileVersion", DOTVERSION VALUE "ProductName", "Package " PROJECT " for Tcl" - VALUE "ProductVersion", DOTVERSION + VALUE "ProductVersion", DOTVERSION END END BLOCK "VarFileInfo" @@ -1667,7 +1697,7 @@ $< << -{$(WINDIR)}.c{$(TMP_DIR)}.obj:: +{$(WIN_DIR)}.c{$(TMP_DIR)}.obj:: $(CCPKGCMD) @<< $< << @@ -1685,7 +1715,7 @@ {$(RCDIR)}.rc{$(TMP_DIR)}.res: $(RESCMD) $< -{$(WINDIR)}.rc{$(TMP_DIR)}.res: +{$(WIN_DIR)}.rc{$(TMP_DIR)}.res: $(RESCMD) $< {$(TMP_DIR)}.rc{$(TMP_DIR)}.res: @@ -1720,7 +1750,7 @@ !if defined(CORE_MACHINE) && "$(CORE_MACHINE)" != "$(MACHINE)" !error ERROR: Build target ($(MACHINE)) does not match the Tcl library architecture ($(CORE_MACHINE)). !endif -!if defined(CORE_USE_THREAD_ALLOC) && $(CORE_USE_THREAD_ALLOC) != $(USE_THREAD_ALLOC) +!if $(TCL_VERSION) < 87 && defined(CORE_USE_THREAD_ALLOC) && $(CORE_USE_THREAD_ALLOC) != $(USE_THREAD_ALLOC) !message WARNING: Value of USE_THREAD_ALLOC ($(USE_THREAD_ALLOC)) does not match its Tcl core value ($(CORE_USE_THREAD_ALLOC)). !endif !if defined(CORE_DEBUG) && $(CORE_DEBUG) != $(DEBUG)