Tcl Source Code

2011-03-28  Donal K. Fellows  <[email protected]>

	* generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd): Use the
	error messages generated by the variable management code rather than
	creating our own.

2011-03-27  Miguel Sofer  <[email protected]>

	* generic/tclBasic.c (TclNREvalObjEx): fix performance issue,
	notably apparent in tclbench's "LIST lset foreach". Many thanks to
	twylite for patiently researching the issue and explaining it to
	me: a missing Tcl_ResetObjResult that causes unwanted sharing of
	the current result Tcl_Obj.

2011-03-26  Donal K. Fellows  <[email protected]>

	* generic/tclNamesp.c (Tcl_Export, Tcl_Import, DoImport): More
	generation of errorCode information.

	* generic/tclCompExpr.c, generic/tclCompile.c, generic/tclExecute.c:

		if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
			!= TCL_OK) {
		    Tcl_DecrRefCount(newPtr);
		    Tcl_DecrRefCount(resultPtr);
		    return TCL_ERROR;
		}
	    } else {


		if (Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr,
			TCL_LEAVE_ERR_MSG) == NULL) {


		    return TCL_ERROR;
		}
	    }
	}

	if (all == 0) {
	    break;

	resultPtr = objv[1];
	Tcl_IncrRefCount(resultPtr);
    } else if (offset < wlen) {
	Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
    }
    if (objc == 4) {
	if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr,

		TCL_LEAVE_ERR_MSG) == NULL) {
	    result = TCL_ERROR;
	} else {
	    /*
	     * Set the interpreter's object result to an integer object
	     * holding the number of matches.
	     */

    VarHashDeleteTable(varPtr->value.tablePtr);
    ckfree(varPtr->value.tablePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjVarErrMsg --
 *
 *	Generate a reasonable error message describing why a variable
 *	operation failed.
 *
 * Results:
 *	None.
 *

# Commands covered:  regexp, regsub
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

unset -nocomplain foo

testConstraint exec [llength [info commands exec]]

test regexp-1.1 {basic regexp operation} {
    regexp ab*c abbbc
} 1
test regexp-1.2 {basic regexp operation} {

    regexp -nocase FOo abcFOo
} 1
set x abcdefghijklmnopqrstuvwxyz1234567890
set x $x$x$x$x$x$x$x$x$x$x$x$x
test regexp-4.4 {case conversion in regexp} {
    list [regexp -nocase $x $x foo] $foo
} "1 $x"
unset -nocomplain x

test regexp-5.1 {exercise cache of compiled expressions} {
    regexp .*a b
    regexp .*b c
    regexp .*c d
    regexp .*d e
    regexp .*e f

} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexp-6.6 {regexp errors} {
    list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg
} {0 1}
test regexp-6.7 {regexp errors} {
    list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg
} {0 0}
test regexp-6.8 {regexp errors} -setup {
    unset -nocomplain f1
} -body {
    set f1 44
    regexp abc abc f1(f2)
} -returnCodes error -result {can't set "f1(f2)": variable isn't array}
test regexp-6.9 {regexp errors, -start bad int check} {
    list [catch {regexp -start bogus {^$} {}} msg] $msg
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
test regexp-6.10 {regexp errors} {
    list [catch {regexp {a[} b} msg] $msg
} {1 {couldn't compile regular expression pattern: brackets [] not balanced}}

} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
test regexp-11.5 {regsub errors} {
    list [catch {regsub -gorp a b c} msg] $msg
} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
test regexp-11.6 {regsub errors} {
    list [catch {regsub -nocase a( b c d} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexp-11.7 {regsub errors} -setup {
    unset -nocomplain f1
} -body {
    set f1 44
    regsub -nocase aaa aaa xxx f1(f2)
} -returnCodes error -result {can't set "f1(f2)": variable isn't array}
test regexp-11.8 {regsub errors, -start bad int check} {
    list [catch {regsub -start bogus pattern string rep var} msg] $msg
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
test regexp-11.9 {regsub without final variable name returns value} {
    regsub b abaca X
} {aXaca}
test regexp-11.10 {regsub without final variable name returns value} {

} -body {
    exec [interpreter] $junk
} -cleanup {
    removeFile junk.tcl
} -result 1

test regexp-15.1 {regexp -start} {
    unset -nocomplain x
    list [regexp -start -10 {\d} 1abc2de3 x] $x
} {1 1}
test regexp-15.2 {regexp -start} {
    unset -nocomplain x
    list [regexp -start 2 {\d} 1abc2de3 x] $x
} {1 2}
test regexp-15.3 {regexp -start} {
    unset -nocomplain x
    list [regexp -start 4 {\d} 1abc2de3 x] $x
} {1 2}
test regexp-15.4 {regexp -start} {
    unset -nocomplain x
    list [regexp -start 5 {\d} 1abc2de3 x] $x
} {1 3}
test regexp-15.5 {regexp -start, over end of string} {
    unset -nocomplain x
    list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
} {0 0}
test regexp-15.6 {regexp -start, loss of ^$ behavior} {
    list [regexp -start 2 {^$} {}]
} {0}
test regexp-15.7 {regexp -start, double option} {
    regexp -start 2 -start 0 a abc
} 1
test regexp-15.8 {regexp -start, double option} {
    regexp -start 0 -start 2 a abc
} 0
test regexp-15.9 {regexp -start, end relative index} {
    unset -nocomplain x
    list [regexp -start end {\d} 1abc2de3 x] [info exists x]
} {0 0}
test regexp-15.10 {regexp -start, end relative index} {
    unset -nocomplain x
    list [regexp -start end-1 {\d} 1abc2de3 x] [info exists x] $x
} {1 1 3}
test regexp-15.11 {regexp -start, over end of string} {
    set x NA
    list [regexp -start 2 {.*} ab x] $x
} {1 {}}

test regexp-16.1 {regsub -start} {
    unset -nocomplain x
    list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
} {4 a1b/2c/3d/4e/5}
test regexp-16.2 {regsub -start} {
    unset -nocomplain x
    list [regsub -all -start -25 {z} hello {/&} x] $x
} {0 hello}
test regexp-16.3 {regsub -start} {
    unset -nocomplain x
    list [regsub -all -start 3 {z} hello {/&} x] $x
} {0 hello}
test regexp-16.4 {regsub -start, \A behavior} {
    set out {}
    lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
    lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
} {5 /a/b/c/d/e 3 ab/c/d/e}

    regexp -all -inline -- {a*} "b\n"
} {{} {}}

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

	testProc 
    } result]
    rename testProc {}
    return $result
    #return [list $status $result]
}

unset -nocomplain foo

test regexpComp-1.1 {basic regexp operation} {
    evalInProc {
	regexp ab*c abbbc
    }
} 1
test regexpComp-1.2 {basic regexp operation} {
    evalInProc {

set ::x abcdefghijklmnopqrstuvwxyz1234567890
set ::x $x$x$x$x$x$x$x$x$x$x$x$x
test regexpComp-4.4 {case conversion in regexp} {
    evalInProc {
	list [regexp -nocase $::x $::x foo] $foo
    }
} "1 $x"
unset -nocomplain ::x

test regexpComp-5.1 {exercise cache of compiled expressions} {
    evalInProc {
	regexp .*a b
	regexp .*b c
	regexp .*c d
	regexp .*d e

test regexpComp-6.7 {regexp errors} {
    evalInProc {
	list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg
    }
} {0 0}
test regexpComp-6.8 {regexp errors} {
    evalInProc {
	unset -nocomplain f1
	set f1 44
	list [catch {regexp abc abc f1(f2)} msg] $msg
    }
} {1 {can't set "f1(f2)": variable isn't array}}
test regexpComp-6.9 {regexp errors, -start bad int check} {
    evalInProc {
	list [catch {regexp -start bogus {^$} {}} msg] $msg
    }
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}

test regexpComp-7.1 {basic regsub operation} {

test regexpComp-11.6 {regsub errors} {
    evalInProc {
	list [catch {regsub -nocase a( b c d} msg] $msg
    }
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-11.7 {regsub errors} {
    evalInProc {
	unset -nocomplain f1
	set f1 44
	list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
    }
} {1 {can't set "f1(f2)": variable isn't array}}
test regexpComp-11.8 {regsub errors, -start bad int check} {
    evalInProc {
	list [catch {regsub -start bogus pattern string rep var} msg] $msg
    }
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}

# This test crashes on the Mac unless you increase the Stack Space to about 1

} -body {
    exec [interpreter] $junk
} -cleanup {
    removeFile junk.tcl
} -result 1

test regexpComp-15.1 {regexp -start} {
    unset -nocomplain x
    list [regexp -start -10 {\d} 1abc2de3 x] $x
} {1 1}
test regexpComp-15.2 {regexp -start} {
    unset -nocomplain x
    list [regexp -start 2 {\d} 1abc2de3 x] $x
} {1 2}
test regexpComp-15.3 {regexp -start} {
    unset -nocomplain x
    list [regexp -start 4 {\d} 1abc2de3 x] $x
} {1 2}
test regexpComp-15.4 {regexp -start} {
    unset -nocomplain x
    list [regexp -start 5 {\d} 1abc2de3 x] $x
} {1 3}
test regexpComp-15.5 {regexp -start, over end of string} {
    unset -nocomplain x
    list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
} {0 0}
test regexpComp-15.6 {regexp -start, loss of ^$ behavior} {
    list [regexp -start 2 {^$} {}]
} {0}

test regexpComp-16.1 {regsub -start} {
    unset -nocomplain x
    list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
} {4 a1b/2c/3d/4e/5}
test regexpComp-16.2 {regsub -start} {
    unset -nocomplain x
    list [regsub -all -start -25 {z} hello {/&} x] $x
} {0 hello}
test regexpComp-16.3 {regsub -start} {
    unset -nocomplain x
    list [regsub -all -start 3 {z} hello {/&} x] $x
} {0 hello}
test regexpComp-16.4 {regsub -start, \A behavior} {
    set out {}
    lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
    lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
} {5 /a/b/c/d/e 3 ab/c/d/e}

	regexp -- $re $text
    }
} 1

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

fi
echo "$as_me:$LINENO: result: $tcl_cv_cc_visibility_hidden" >&5
echo "${ECHO_T}$tcl_cv_cc_visibility_hidden" >&6
    if test $tcl_cv_cc_visibility_hidden = yes; then

	CFLAGS="$CFLAGS -fvisibility=hidden"

cat >>confdefs.h <<\_ACEOF
#define MODULE_SCOPE extern
_ACEOF


else


cat >>confdefs.h <<\_ACEOF
#define NO_VIZ
_ACEOF

	    if test "$tcl_cv_cc_visibility_hidden" != yes; then


cat >>confdefs.h <<\_ACEOF
#define MODULE_SCOPE __private_extern__
_ACEOF

		tcl_cv_cc_visibility_hidden=yes

fi

	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"

	    CYGWIN_*) ;;
	    IRIX*) ;;
	    NetBSD-*|FreeBSD-*|OpenBSD-*) ;;
	    Darwin-*) ;;
	    SCO_SV-3.2*) ;;
	    *) SHLIB_CFLAGS="-fPIC" ;;
	esac
fi


    if test "$tcl_cv_cc_visibility_hidden" != yes; then


cat >>confdefs.h <<\_ACEOF
#define MODULE_SCOPE extern
_ACEOF


cat >>confdefs.h <<\_ACEOF
#define NO_VIZ
_ACEOF


fi


    if test "$SHARED_LIB_SUFFIX" = ""; then

	SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}'
fi

		CFLAGS=$hold_cflags
	    ], [
		tcl_cv_cc_visibility_hidden=no
	    ])
    ])
    AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [
	CFLAGS="$CFLAGS -fvisibility=hidden"
	AC_DEFINE(MODULE_SCOPE, [extern], [No need to mark inidividual symbols as hidden])
    ], [

	hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
	AC_TRY_LINK([
	    extern __attribute__((__visibility__("hidden"))) void f(void);
	    void f(void) {}], [f();], tcl_cv_cc_visibility_hidden=yes,
	    tcl_cv_cc_visibility_hidden=no)
	CFLAGS=$hold_cflags
	AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [

		LDFLAGS=$hold_ldflags])
	    AS_IF([test $tcl_cv_ld_search_paths_first = yes], [
		LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
	    ])
	    AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [
		AC_DEFINE(MODULE_SCOPE, [__private_extern__],
		    [Compiler support for module scope symbols])
		tcl_cv_cc_visibility_hidden=yes
	    ])
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"
	    AC_DEFINE(MAC_OSX_TCL, 1, [Is this a Mac I see before me?])
	    PLAT_OBJS='${MAC_OSX_OBJS}'
	    PLAT_SRCS='${MAC_OSX_SRCS}'

	    CYGWIN_*) ;;
	    IRIX*) ;;
	    NetBSD-*|FreeBSD-*|OpenBSD-*) ;;
	    Darwin-*) ;;
	    SCO_SV-3.2*) ;;
	    *) SHLIB_CFLAGS="-fPIC" ;;
	esac])

    AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [
	AC_DEFINE(MODULE_SCOPE, [extern],
	    [No Compiler support for module scope symbols])
	AC_DEFINE(NO_VIZ, [], [No visibility attribute])
    ])

    AS_IF([test "$SHARED_LIB_SUFFIX" = ""], [
	SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}'])
    AS_IF([test "$UNSHARED_LIB_SUFFIX" = ""], [
	UNSHARED_LIB_SUFFIX='${VERSION}.a'])
	DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)"

  CELIB_DIR=NO_CELIB
fi;
    echo "$as_me:$LINENO: result: $CELIB_DIR" >&5
echo "${ECHO_T}$CELIB_DIR" >&6

    # Set some defaults (may get changed below)
    EXTRA_CFLAGS=""

cat >>confdefs.h <<\_ACEOF
#define MODULE_SCOPE extern
_ACEOF


    # Extract the first word of "cygpath", so it can be a program name with args.
set dummy cygpath; ac_word=$2
echo "$as_me:$LINENO: checking for $ac_word" >&5
echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
if test "${ac_cv_prog_CYGPATH+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6

    AC_MSG_CHECKING([for Windows/CE celib directory])
    AC_ARG_WITH(celib,[  --with-celib=DIR        use Windows/CE support library from DIR],
	    CELIB_DIR=$withval, CELIB_DIR=NO_CELIB)
    AC_MSG_RESULT([$CELIB_DIR])

    # Set some defaults (may get changed below)
    EXTRA_CFLAGS=""
	AC_DEFINE(MODULE_SCOPE, [extern], [No need to mark inidividual symbols as hidden])

    AC_CHECK_PROG(CYGPATH, cygpath, cygpath -w, echo)

    SHLIB_SUFFIX=".dll"

    # MACHINE is IX86 for LINK, but this is used by the manifest,
    # which requires x86|amd64|ia64.