Tcl Source Code

#define TCL_MINOR_VERSION   0
#define TCL_RELEASE_LEVEL   TCL_ALPHA_RELEASE
#define TCL_RELEASE_SERIAL  0

#define TCL_VERSION	    "9.0"
#define TCL_PATCH_LEVEL	    "9.0a0"











/*
 * A special definition used to allow this header file to be included from
 * windows resource files so that they can obtain version information.
 * RC_INVOKED is defined by default by the windows RC tool.
 *
 * Resource compilers don't like all the C stuff, like typedefs and function
 * declarations, that occur below, so block them out.

				 * here, otherwise the pointer to the
				 * requested Command struct to be invoked. */
{
    Interp *iPtr = (Interp *) interp;

    /*
     * data[1] stores a marker for use by tailcalls; it will be set to 1 by
     * command redirectors (imports, alias, ensembles) so that tailcall skips
     * this callback (that marks the end of the target command) and goes back
     * to the end of the source command. 
     */

    if (iPtr->deferredCallbacks) {
        iPtr->deferredCallbacks = NULL;
    } else {
	TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
    }

    int result)
{
    Interp *iPtr = (Interp *) interp;

    iPtr->numLevels--;

     /*
      * If there is a tailcall, schedule it next
      */
 
    if (data[1] && (data[1] != INT2PTR(1))) {
        TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL);
    }

    /* OPT ??

    int flags)
{
    return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR,
	    (Command *) cmd);
}

/*****************************************************************************
 * Tailcall related code
 *****************************************************************************
 *



 * The steps of the tailcall dance are as follows:

 *
 *   1. when [tailcall] is invoked, it stores the corresponding callback in

 *      the current CallFrame and returns TCL_RETURN
 *   2. when the CallFrame is popped, it calls TclSetTailcall to store the
 *      callback in the proper NRCommand callback - the spot where the command
 *      that pushed the CallFrame is completely cleaned up

 *   3. when the NRCommand callback runs, it schedules the tailcall callback





 *      to run immediately after it returns
 *

 *   One delicate point is to properly define the NRCommand where the tailcall
 *   will execute. There are functions whose purpose is to help define the
 *   precise spot: TclMarkTailcall ("this is the spot") and TclSkipTailcall
 *   ("skip the next command: we are redirecting to it, tailcalls should run
 *   after WE return"), TclPushTailcallPoint (special for OO).
 */

void
TclMarkTailcall(
    Tcl_Interp *interp)
{
    Interp *iPtr = (Interp *) interp;

TclPushTailcallPoint(
    Tcl_Interp *interp)
{
    TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
    ((Interp *) interp)->numLevels++;
}


/*
 *----------------------------------------------------------------------
 *
 * TclSetTailcall --
 *
 *	Splice a tailcall command in the proper spot of the NRE callback
 *	stack, so that it runs at the right time.
 *
 *----------------------------------------------------------------------
 */

void
TclSetTailcall(
    Tcl_Interp *interp,
    Tcl_Obj *listPtr)
{
    /*
     * Find the splicing spot: right before the NRCommand of the thing

    }
    if (!runPtr) {
        Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!");
    }
    runPtr->data[1] = listPtr;
}


/*
 *----------------------------------------------------------------------
 *
 * TclNRTailcallObjCmd --
 *
 *	Prepare the tailcall as a list and store it in the current
 *	varFrame. When the frame is later popped the tailcall will be spliced
 *	at the proper place.
 *
 * Results:
 *	The first NRCommand callback that is not marked to be skipped is
 *	updated so that its data[1] field contains the tailcall list.
 *
 *----------------------------------------------------------------------
 */

int
TclNRTailcallObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Interp *iPtr = (Interp *) interp;

    if (objc < 1) {
	Tcl_WrongNumArgs(interp, 1, objv, "?command? ?arg ...?");
	return TCL_ERROR;
    }

    if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "tailcall can only be called from a proc, lambda or method", -1));
        Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
	return TCL_ERROR;
    }

    /*
     * Invocation without args just clears a scheduled tailcall; invocation
     * with an argument replaces any previously scheduled tailcall.
     */

    if (iPtr->varFramePtr->tailcallPtr) {
        Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
        iPtr->varFramePtr->tailcallPtr = NULL;
    }

    /*
     * Create the callback to actually evaluate the tailcalled
     * command, then set it in the varFrame so that PopCallFrame can use it
     * at the proper time.

     */

    if (objc > 1) {
        Tcl_Obj *listPtr, *nsObjPtr;
        Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
        Tcl_Namespace *ns1Ptr;

 	TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
        
        iPtr->varFramePtr->tailcallPtr = listPtr;
    }
    return TCL_RETURN;
}


/*
 *----------------------------------------------------------------------
 *
 * TclNRTailcallEval --
 *
 *	This NREcallback actually causes the tailcall to be evaluated.
 *
 *----------------------------------------------------------------------
 */

int
TclNRTailcallEval(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;

	iPtr->ensembleRewrite.sourceObjs = objv;
	iPtr->ensembleRewrite.numRemovedObjs = opnd;
	iPtr->ensembleRewrite.numInsertedObjs = 1;
	DECACHE_STACK_INFO();
	pc += 6;
	TEBC_YIELD();

	TclMarkTailcall(interp);
	TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL);

	return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN);

    /*
     * -----------------------------------------------------------------
     *	   Start of INST_LOAD instructions.
     *
     * WARNING: more 'goto' here than your doctor recommended! The different

    a 0
} -cleanup {
    rename a {}
    rename b {}
} -constraints {
    testnrelevels
} -result {{0 2 1 1} 0}

test nre-4.2 {(compiled) ensembles do not break tailcall} -setup {
    # Fix Bug d87cb18205
    proc b {} {
	tailcall append result first
    }
    set map [namespace ensemble configure ::dict -map]
    dict set map a b
    namespace ensemble configure ::dict -map $map
    proc demo {} {
	dict a
	append result second
    }
} -body {
    demo
} -cleanup {
    rename demo {}
    namespace ensemble configure ::dict -map [dict remove $map a]
    unset map
    rename b {}
} -result firstsecond

test nre-5.1 {[namespace eval] is not recursive} -setup {
    namespace eval ::foo {
	setabs
    }
    proc foo::a i [makebody {namespace eval ::foo [list a $i]}]
} -body {

    namespace ensemble create -command a -map {b b}
} -body {
    a b 0
} -cleanup {
    rename a {}
    rename b {}
} -result {0 0 0 0 0 0}

test tailcall-0.5.1 {tailcall is constant space} -constraints testnrelevels -setup {
    # 
    # This test is related to [bug d87cb182053fd79b3]: the fix to that bug was
    # to remove a call to TclSkipTailcall, which caused a violation of the
    # constant-space property of tailcall in that particular
    # configuration. This test was added to detect that, and insure that the
    # problem is fixed.
    #

    proc b i {
	if {$i == 1} {
	    depthDiff
	}
	if {[incr i] > 10} {
	    return [depthDiff]
	}
	tailcall dict b $i
    }
    set map0 [namespace ensemble configure dict -map]
    set map $map0
    dict set map b b
    namespace ensemble configure dict -map $map
} -body {
    dict b 0
} -cleanup {
    rename b {}
    namespace ensemble configure dict -map $map0
    unset map map0
} -result {0 0 0 0 0 0}

test tailcall-0.6 {tailcall is constant space} -constraints {testnrelevels knownBug} -setup {
    #
    # This test fails because ns-unknown is not NR-enabled
    #
    proc c i {
	if {$i == 1} {

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

#include "tcl.h"
#define WIN32_LEAN_AND_MEAN
#define STRICT			/* See MSDN Article Q83456 */
#include <windows.h>
#undef STRICT
#undef WIN32_LEAN_AND_MEAN
#include <locale.h>
#include <stdlib.h>
#include <tchar.h>

#ifdef TCL_TEST
extern Tcl_PackageInitProc Tcltest_Init;

    DWORD nbytes,
    LPDWORD nbytesread)
{
    DWORD ntchars;
    BOOL result;
    int tcharsize = sizeof(TCHAR);

    /*
     * If user types a Ctrl-Break or Ctrl-C, ReadConsole will return
     * success with ntchars == 0 and GetLastError() will be
     * ERROR_OPERATION_ABORTED. We do not want to treat this case
     * as EOF so we will loop around again. If no Ctrl signal handlers
     * have been established, the default signal OS handler in a separate 
     * thread will terminate the program. If a Ctrl signal handler
     * has been established (through an extension for example), it
     * will run and take whatever action it deems appropriate.
     */
    do {
        result = ReadConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars,
                             NULL);
    } while (result && ntchars == 0 && GetLastError() == ERROR_OPERATION_ABORTED);
    if (nbytesread != NULL) {
	*nbytesread = ntchars * tcharsize;
    }
    return result;
}

static BOOL