Tcl Source Code

2011-04-11  Miguel Sofer  <[email protected]>

	* generic/tclBasic.c:
	* tests/coroutine.test: insure that 'coroutine eval' runs the initial
	command in the proper context, [Bug 3282869]
	
2011-04-11  Jan Nijtmans  <[email protected]>
	* generic/tcl.h:    fix for [Bug 3281728]: Tcl sources from 2011-04-06 do
	* unix/tcl.m4:      not build on GCC9 (RH9)
	* unix/configure:

2011-04-08  Jan Nijtmans  <[email protected]>

	* win/tclWinPort.h: fix for [Bug 3280043]: win2k: unresolved DLL imports
	* win/configure.in
	* win/configure

2011-04-06  Miguel Sofer  <[email protected]>

	* generic/tclExecute.c (TclCompileObj): earlier return if Tip280
	gymnastics not needed.

	* generic/tclExecute.c: fix for [Bug 3274728], making *catchTop an
	unsigned long.

2011-04-06  Jan Nijtmans  <[email protected]>

	* unix/tclAppInit.c:  Make symbols "main" and "Tcl_AppInit"
	MODULE_SCOPE: there is absolutely no reason for exporting them.
	* unix/tcl.m4:        Don't use -fvisibility=hidden with static
	* unix/configure      libraries (--disable-shared)

#   else
#       define DLLIMPORT __declspec(dllimport)
#       define DLLEXPORT __declspec(dllexport)
#       define CRTIMPORT __declspec(dllimport)
#   endif
#else
#   define DLLIMPORT
#   if defined(__GNUC__) && __GNUC__ > 3
#       define DLLEXPORT __attribute__ ((visibility("default")))
#   else
#       define DLLEXPORT
#   endif
#   define CRTIMPORT
#endif

    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Command *cmdPtr;
    CoroutineData *corPtr;
    const char *fullName, *procName;
    Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
    Tcl_DString ds;
    Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr;
    
    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?");
	return TCL_ERROR;
    }

    /*

		    &isNew);

	    Tcl_SetHashValue(newPtr, Tcl_GetHashValue(hePtr));
	}
    }

    /*
     * Create the base context.
     */

    corPtr->running.framePtr = iPtr->rootFramePtr;
    corPtr->running.varFramePtr = iPtr->rootFramePtr;
    corPtr->running.cmdFramePtr = NULL;
    corPtr->running.lineLABCPtr = corPtr->lineLABCPtr;
    corPtr->stackLevel = NULL;
    corPtr->auxNumLevels = 0;
    iPtr->numLevels--;
    
    /*
     * Create the coro's execEnv, switch to it to push the exit and coro
     * command callbacks, then switch back. 
     */

    corPtr->eePtr = TclCreateExecEnv(interp, CORO_STACK_INITIAL_SIZE);
    corPtr->callerEEPtr = iPtr->execEnvPtr;
    corPtr->eePtr->corPtr = corPtr;
    
    SAVE_CONTEXT(corPtr->caller);
    corPtr->callerEEPtr = iPtr->execEnvPtr;
    RESTORE_CONTEXT(corPtr->running);
    iPtr->execEnvPtr = corPtr->eePtr;

    TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
	    NULL, NULL, NULL);

    iPtr->lookupNsPtr = lookupNsPtr;
    Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);

    SAVE_CONTEXT(corPtr->running);
    RESTORE_CONTEXT(corPtr->caller);
    iPtr->execEnvPtr = corPtr->callerEEPtr;
    
    /*
     * Now just resume the coroutine. Take care to insure that the command is
     * looked up in the correct namespace.
     */

 */

typedef struct TEBCdata {
    ByteCode *codePtr;		/* Constant until the BC returns */
				/* -----------------------------------------*/
    Tcl_Obj **tosPtr;
    const unsigned char *pc;	/* These fields are used on return TO this */
    unsigned long catchDepth;	        /* this level: they record the state when a */
    int cleanup;		/* new codePtr was received for NR */
    Tcl_Obj *auxObjList;	/* execution. */
    int checkInterp;
    unsigned int capacity;
    CmdFrame cmdFrame;
    void * stack[1];            /* Start of the actual combined catch and obj
				 * stacks; the struct will be expanded as

#define OBJ_AT_TOS	*tosPtr

#define OBJ_UNDER_TOS	*(tosPtr-1)

#define OBJ_AT_DEPTH(n)	*(tosPtr-(n))

#define CURR_DEPTH	((unsigned long) (tosPtr - initTosPtr))

/*
 * Macros used to trace instruction execution. The macros TRACE,
 * TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is
 * only used in TRACE* calls to get a string from an object.
 */

	 *     offset between saved starting line and actual one. Then modify
	 *     the users to adjust the locations they have by this offset.
	 *
	 * (3) Alternative 2: Do not fully recompile, adjust just the location
	 *     information.
	 */

	if (!invoker) {
	    return codePtr;
	}
	
	{
	    Tcl_HashEntry *hePtr =
		    Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
	    ExtCmdLoc *eclPtr;
	    CmdFrame *ctxPtr;
	    int redo;

	    if (!hePtr) {
		return codePtr;
	    }

	    eclPtr = Tcl_GetHashValue(hePtr);
	    redo = 0;
	    ctxPtr = ckalloc(sizeof(CmdFrame));
	    *ctxPtr = *invoker;

	set end [getbytes]
    }
    set leakedBytes [expr {$end - $start}]
} -cleanup {
    rename getbytes {}
    unset i ns start end
} -result 0

test coroutine-4.6 {compile context, bug #3282869} -setup {
    unset ::x
    proc f x {
	coroutine D eval {yield X$x;yield Y}
    }
} -body {
    f 12
} -cleanup {
    rename f {}
} -returnCodes error -match glob -result {can't read *}

test coroutine-4.7 {compile context, bug #3282869} -setup {
    proc f x {
	coroutine D eval {yield X$x;yield Y$x}
    }
} -body {
    set ::x 15
    set ::x [f 12]
    D
} -cleanup {
    unset ::x
    rename f {}
} -result YX15

test coroutine-5.1 {right numLevels on coro return} -constraints {testnrelevels} \
-setup {
    proc nestedYield {{val {}}} {
	yield $val
    }
    proc getNumLevel {} {

    list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode
} -match glob \
    -result [list 1 {cannot find symbol "Foo_Init"*} \
		 {TCL LOOKUP LOAD_SYMBOL *Foo_Init}]
test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] {
    list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg
} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}}
# This test fails due to --export-dynamic
test load-2.5 {loading package with symbol conflict, this test fails when using  --export-dynamic} [list $dll $loaded] {
    pkga_quote
} {I'm in pkga.c}

test load-3.1 {error in _Init procedure, same interpreter} \
	[list $dll $loaded] {
    list [catch {load [file join $testDir pkge$ext] pkge} msg] \
	    $msg $::errorInfo $::errorCode
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
    while executing

    echo "$as_me:$LINENO: checking if compiler supports visibility \"hidden\"" >&5
echo $ECHO_N "checking if compiler supports visibility \"hidden\"... $ECHO_C" >&6
if test "${tcl_cv_cc_visibility_hidden+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

	    if test "$SHARED_BUILD" = 1; then

		hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fvisibility=hidden -Werror"
		cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{
#if !defined(__GNUC__) || __GNUC__ < 4
#error visibility hidden is not supported for this compiler
#endif

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5

 * Prototypes for procedures defined later in this file:
 */

static int    Pkga_EqObjCmd(ClientData clientData,
		Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int    Pkga_QuoteObjCmd(ClientData clientData,
		Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
/*
 * Function to be backlinked from the tcltest executable
 */
#if 0
extern const char *Tcltest_Foo();
#else
EXTERN const char *Tcltest_Foo() {
    return "I'm in pkga.c";
}
#endif


/*
 *----------------------------------------------------------------------
 *
 * Pkga_EqObjCmd --
 *
 *	This procedure is invoked to process the "pkga_eq" Tcl command. It

static int
Pkga_QuoteObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument strings. */
{
    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "value");
	return TCL_ERROR;
    }
    if (objc == 1) {
	Tcl_SetResult(interp, (char *) Tcltest_Foo(), TCL_VOLATILE);
    } else {
    Tcl_SetObjResult(interp, objv[1]);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Pkga_Init --

 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#undef STATIC_BUILD
#include "tcl.h"
#include <stdio.h>

/*
 * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
 * Pkgua_Init declaration is in the source file itself, which is only
 * accessed when we are building a library.
 */
#undef TCL_STORAGE_CLASS

static int
PkguaQuoteObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument strings. */
{
    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "value");
	return TCL_ERROR;
    }
    if (objc == 1) {
	int major, minor, patch, type;
	char result[128];

#undef Tcl_GetVersion /* Link this symbol without stubs */
	Tcl_GetVersion(&major, &minor, &patch, &type);
	sprintf(result, "%d %d %d %d", major, minor, patch, type);
	Tcl_SetResult(interp, result, TCL_VOLATILE);
    } else {
    Tcl_SetObjResult(interp, objv[1]);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Pkgua_Init --

    AS_IF([test "$do64bitVIS" = "yes"], [do64bit=yes])

    # Step 0.c: Check if visibility support is available. Do this here so
    # that platform specific alternatives can be used below if this fails.

    AC_CACHE_CHECK([if compiler supports visibility "hidden"],
	tcl_cv_cc_visibility_hidden, [
	    AS_IF([test "$SHARED_BUILD" = 1], [
		hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fvisibility=hidden -Werror"
		AC_TRY_COMPILE(,[#if !defined(__GNUC__) || __GNUC__ < 4
#error visibility hidden is not supported for this compiler
#endif
		], tcl_cv_cc_visibility_hidden=yes,
		    tcl_cv_cc_visibility_hidden=no)
		CFLAGS=$hold_cflags
	    ], [
		tcl_cv_cc_visibility_hidden=no
	    ])
    ])
    AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [

    (Tcl_SetVar)(interp, "tcl_rcFileName", "~/tclsh.rc", TCL_GLOBAL_ONLY);
#else
    (Tcl_SetVar)(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY);
#endif

    return TCL_OK;
}

#ifdef TCL_TEST
#   undef TCL_STORAGE_CLASS
#   define TCL_STORAGE_CLASS DLLEXPORT
EXTERN const char *Tcltest_Foo() {
    return "I'm in tclAppInit.c";
}
#endif /* TCL_TEST */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:

echo "${ECHO_T}$tcl_cv_intrinsics" >&6
if test "$tcl_cv_intrinsics" = "yes"; then

cat >>confdefs.h <<\_ACEOF
#define HAVE_INTRIN_H 1
_ACEOF

fi

# See if the <wspiapi.h> header file is present

echo "$as_me:$LINENO: checking for wspiapi.h" >&5
echo $ECHO_N "checking for wspiapi.h... $ECHO_C" >&6
if test "${tcl_have_wspiapi_h+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

#include <wspiapi.h>

int
main ()
{

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_have_wspiapi_h=yes
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_have_wspiapi_h=no
fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext

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

cat >>confdefs.h <<\_ACEOF
#define HAVE_WSPIAPI_H 1
_ACEOF

fi

#--------------------------------------------------------------------
# Determines the correct binary file extension (.o, .obj, .exe etc.)
#--------------------------------------------------------------------

        tcl_cv_intrinsics=yes,
        tcl_cv_intrinsics=no)
)
if test "$tcl_cv_intrinsics" = "yes"; then
    AC_DEFINE(HAVE_INTRIN_H, 1,
            [Defined when the compilers supports intrinsics])
fi

# See if the <wspiapi.h> header file is present    

AC_CACHE_CHECK(for wspiapi.h,
    tcl_have_wspiapi_h,
AC_TRY_COMPILE([
#include <wspiapi.h>
], [],
        tcl_have_wspiapi_h=yes,
        tcl_have_wspiapi_h=no)
)
if test "$tcl_have_wspiapi_h" = "yes"; then
    AC_DEFINE(HAVE_WSPIAPI_H, 1,
            [Defined when wspiapi.h exists])
fi

#--------------------------------------------------------------------
# Determines the correct binary file extension (.o, .obj, .exe etc.)
#--------------------------------------------------------------------

AC_OBJEXT
AC_EXEEXT

/*
 * Ask for the winsock function typedefs, also.
 */
#define INCL_WINSOCK_API_TYPEDEFS   1
#include <winsock2.h>
#include <ws2tcpip.h>
#ifdef HAVE_WSPIAPI_H
#   include <wspiapi.h>
#endif

#ifdef CHECK_UNICODE_CALLS
#   define _UNICODE
#   define UNICODE
#   define __TCHAR_DEFINED
    typedef float *_TCHAR;
#   define _TCHAR_DEFINED