summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls35
-rw-r--r--generic/tcl.h14
-rw-r--r--generic/tclBasic.c1880
-rw-r--r--generic/tclCmdAH.c5
-rw-r--r--generic/tclCompile.h4
-rw-r--r--generic/tclDecls.h76
-rw-r--r--generic/tclExecute.c762
-rw-r--r--generic/tclHistory.c4
-rw-r--r--generic/tclInt.decls26
-rw-r--r--generic/tclInt.h67
-rw-r--r--generic/tclIntDecls.h64
-rw-r--r--generic/tclInterp.c90
-rw-r--r--generic/tclNamesp.c213
-rw-r--r--generic/tclProc.c321
-rw-r--r--generic/tclStubInit.c14
-rw-r--r--generic/tclTestProcBodyObj.c6
16 files changed, 2609 insertions, 972 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 6c9b09a..460d6dc 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tcl.decls,v 1.133 2008/06/13 05:45:07 mistachkin Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.134 2008/07/13 09:03:32 msofer Exp $
library tcl
@@ -2108,6 +2108,39 @@ declare 581 generic {
int Tcl_Canceled(Tcl_Interp *interp, int flags)
}
+# NRE public interface
+declare 582 generic {
+ Tcl_Command TclNR_CreateCommand(Tcl_Interp *interp,
+ CONST char *cmdName, Tcl_ObjCmdProc *proc,
+ Tcl_ObjCmdProc *nreProc, ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc)
+}
+declare 583 generic {
+ int TclNR_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
+}
+declare 584 generic {
+ int TclNR_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[],
+ int flags)
+}
+declare 585 generic {
+ int TclNR_ObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc,
+ ClientData clientData)
+}
+declare 586 generic {
+ void TclNR_AddCallback(Tcl_Interp *interp, TclNR_PostProc *postProcPtr,
+ ClientData data0, ClientData data1,
+ ClientData data2, ClientData data3)
+}
+
+# For use by NR extenders, to have a simple way to also provide a (required!)
+# classic objProc
+declare 587 generic {
+ int TclNR_CallObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc,
+ ClientData clientData, int objc,
+ Tcl_Obj *const objv[])
+}
+
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are
diff --git a/generic/tcl.h b/generic/tcl.h
index 65c9eec..50bd3c1 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tcl.h,v 1.259 2008/06/19 15:37:03 dgp Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.260 2008/07/13 09:03:32 msofer Exp $
*/
#ifndef _TCL
@@ -986,12 +986,15 @@ typedef struct Tcl_DString {
* TCL_CANCEL_UNWIND: Magical Tcl_CancelEval mode that causes the
* stack for the script in progress to be
* completely unwound.
+ * TCL_EVAL_NOERR: Do no exception reporting at all, just return
+ * as the caller will report.
*/
#define TCL_NO_EVAL 0x10000
#define TCL_EVAL_GLOBAL 0x20000
#define TCL_EVAL_DIRECT 0x40000
#define TCL_EVAL_INVOKE 0x80000
#define TCL_CANCEL_UNWIND 0x100000
+#define TCL_EVAL_NOERR 0x200000
/*
* Special freeProc values that may be passed to Tcl_SetResult (see the man
@@ -2247,6 +2250,14 @@ EXTERN CONST char * Tcl_PkgInitStubsCheck _ANSI_ARGS_((Tcl_Interp *interp,
EXTERN void Tcl_GetMemoryInfo _ANSI_ARGS_((Tcl_DString *dsPtr));
#endif
+
+/*
+ * Single public declaration for NRE
+ */
+
+typedef int (TclNR_PostProc) (ClientData data[], Tcl_Interp *interp,
+ int result);
+
/*
* Include the public function declarations that are accessible via the stubs
* table.
@@ -2426,6 +2437,7 @@ EXTERN void Tcl_GetMemoryInfo _ANSI_ARGS_((Tcl_DString *dsPtr));
# define panicVA Tcl_PanicVA
#endif
+
/*
* Convenience declaration of Tcl_AppInit for backwards compatibility. This
* function is not *implemented* by the tcl library, so the storage class is
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 6ce696a..cf4bbe4 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -11,11 +11,12 @@
* Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
* Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
+ * Copyright (c) 2008 Miguel Sofer <msofer@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.303 2008/06/13 12:14:32 das Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.304 2008/07/13 09:03:33 msofer Exp $
*/
#include "tclInt.h"
@@ -25,6 +26,7 @@
#include <limits.h>
#include <math.h>
#include "tommath.h"
+#include "tclNRE.h"
/*
* Determine whether we're using IEEE floating point
@@ -59,8 +61,8 @@ static int CancelEvalProc(ClientData clientData,
static int CheckDoubleResult(Tcl_Interp *interp, double dResult);
static void DeleteInterpProc(Tcl_Interp *interp);
static void DeleteOpCmdClientData(ClientData clientData);
-static Tcl_Obj *GetCommandSource(Interp *iPtr, const char *command,
- int numChars, int objc, Tcl_Obj *const objv[]);
+static Tcl_Obj *GetCommandSource(Interp *iPtr, int objc,
+ Tcl_Obj *const objv[], int lookup);
static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode);
static int OldMathFuncProc(ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *const *objv);
@@ -104,6 +106,37 @@ static int DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc,
MODULE_SCOPE const TclStubs * const tclConstStubsPtr;
+
+/*
+ * Block for Tcl_EvalObjv helpers
+ */
+
+static void TEOV_SwitchVarFrame(Tcl_Interp *interp);
+
+static void TEOV_PushExceptionHandlers(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[], int flags);
+
+static inline Command *
+ TEOV_LookupCmdFromObj(Tcl_Interp *interp, Tcl_Obj *namePtr,
+ Namespace *lookupNsPtr);
+
+static int TEOV_NotFound(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[], Namespace *lookupNsPtr);
+
+static int TEOV_RunEnterTraces(Tcl_Interp *interp, Command **cmdPtrPtr,
+ int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr);
+
+static TclNR_PostProc TEOV_RestoreVarFrame;
+static TclNR_PostProc TEOV_RunLeaveTraces;
+static TclNR_PostProc TEOV_Exception;
+static TclNR_PostProc TEOV_Error;
+static TclNR_PostProc TEOEx_ListCallback;
+static TclNR_PostProc TEOEx_ByteCodeCallback;
+
+static int NRPostProcess(Tcl_Interp *interp, int result, int objc,
+ Tcl_Obj *const objv[]);
+
+
/*
* The following structure define the commands in the Tcl core.
*/
@@ -112,6 +145,7 @@ typedef struct {
const char *name; /* Name of object-based command. */
Tcl_ObjCmdProc *objProc; /* Object-based function for command. */
CompileProc *compileProc; /* Function called to compile command. */
+ Tcl_ObjCmdProc *nreProc; /* NR-based function for command */
int isSafe; /* If non-zero, command will be present in
* safe interpreter. Otherwise it will be
* hidden. */
@@ -126,92 +160,92 @@ static const CmdInfo builtInCmds[] = {
* Commands in the generic core.
*/
- {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, 1},
- {"apply", Tcl_ApplyObjCmd, NULL, 1},
- {"array", Tcl_ArrayObjCmd, NULL, 1},
- {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, 1},
+ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, 1},
+ {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, 1},
+ {"array", Tcl_ArrayObjCmd, NULL, NULL, 1},
+ {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, 1},
#ifndef EXCLUDE_OBSOLETE_COMMANDS
- {"case", Tcl_CaseObjCmd, NULL, 1},
+ {"case", Tcl_CaseObjCmd, NULL, NULL, 1},
#endif
- {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, 1},
- {"concat", Tcl_ConcatObjCmd, NULL, 1},
- {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, 1},
- {"error", Tcl_ErrorObjCmd, NULL, 1},
- {"eval", Tcl_EvalObjCmd, NULL, 1},
- {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, 1},
- {"for", Tcl_ForObjCmd, TclCompileForCmd, 1},
- {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, 1},
- {"format", Tcl_FormatObjCmd, NULL, 1},
- {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, 1},
- {"if", Tcl_IfObjCmd, TclCompileIfCmd, 1},
- {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, 1},
- {"join", Tcl_JoinObjCmd, NULL, 1},
- {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, 1},
- {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, 1},
- {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, 1},
- {"linsert", Tcl_LinsertObjCmd, NULL, 1},
- {"list", Tcl_ListObjCmd, TclCompileListCmd, 1},
- {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, 1},
- {"lrange", Tcl_LrangeObjCmd, NULL, 1},
- {"lrepeat", Tcl_LrepeatObjCmd, NULL, 1},
- {"lreplace", Tcl_LreplaceObjCmd, NULL, 1},
- {"lreverse", Tcl_LreverseObjCmd, NULL, 1},
- {"lsearch", Tcl_LsearchObjCmd, NULL, 1},
- {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, 1},
- {"lsort", Tcl_LsortObjCmd, NULL, 1},
- {"namespace", Tcl_NamespaceObjCmd, TclCompileNamespaceCmd, 1},
- {"package", Tcl_PackageObjCmd, NULL, 1},
- {"proc", Tcl_ProcObjCmd, NULL, 1},
- {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, 1},
- {"regsub", Tcl_RegsubObjCmd, NULL, 1},
- {"rename", Tcl_RenameObjCmd, NULL, 1},
- {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, 1},
- {"scan", Tcl_ScanObjCmd, NULL, 1},
- {"set", Tcl_SetObjCmd, TclCompileSetCmd, 1},
- {"split", Tcl_SplitObjCmd, NULL, 1},
- {"subst", Tcl_SubstObjCmd, NULL, 1},
- {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, 1},
- {"trace", Tcl_TraceObjCmd, NULL, 1},
- {"unset", Tcl_UnsetObjCmd, NULL, 1},
- {"uplevel", Tcl_UplevelObjCmd, NULL, 1},
- {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, 1},
- {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, 1},
- {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, 1},
+ {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, NULL, 1},
+ {"concat", Tcl_ConcatObjCmd, NULL, NULL, 1},
+ {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, 1},
+ {"error", Tcl_ErrorObjCmd, NULL, NULL, 1},
+ {"eval", Tcl_EvalObjCmd, NULL, NULL, 1},
+ {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, NULL, 1},
+ {"for", Tcl_ForObjCmd, TclCompileForCmd, NULL, 1},
+ {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, NULL, 1},
+ {"format", Tcl_FormatObjCmd, NULL, NULL, 1},
+ {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1},
+ {"if", Tcl_IfObjCmd, TclCompileIfCmd, NULL, 1},
+ {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, 1},
+ {"join", Tcl_JoinObjCmd, NULL, NULL, 1},
+ {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, 1},
+ {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, 1},
+ {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, 1},
+ {"linsert", Tcl_LinsertObjCmd, NULL, NULL, 1},
+ {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, 1},
+ {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1},
+ {"lrange", Tcl_LrangeObjCmd, NULL, NULL, 1},
+ {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1},
+ {"lreplace", Tcl_LreplaceObjCmd, NULL, NULL, 1},
+ {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, 1},
+ {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1},
+ {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1},
+ {"lsort", Tcl_LsortObjCmd, NULL, NULL, 1},
+ {"namespace", Tcl_NamespaceObjCmd, TclCompileNamespaceCmd, TclNRNamespaceObjCmd, 1},
+ {"package", Tcl_PackageObjCmd, NULL, NULL, 1},
+ {"proc", Tcl_ProcObjCmd, NULL, NULL, 1},
+ {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1},
+ {"regsub", Tcl_RegsubObjCmd, NULL, NULL, 1},
+ {"rename", Tcl_RenameObjCmd, NULL, NULL, 1},
+ {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, 1},
+ {"scan", Tcl_ScanObjCmd, NULL, NULL, 1},
+ {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, 1},
+ {"split", Tcl_SplitObjCmd, NULL, NULL, 1},
+ {"subst", Tcl_SubstObjCmd, NULL, NULL, 1},
+ {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, NULL, 1},
+ {"trace", Tcl_TraceObjCmd, NULL, NULL, 1},
+ {"unset", Tcl_UnsetObjCmd, NULL, NULL, 1},
+ {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, 1},
+ {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1},
+ {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1},
+ {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, NULL, 1},
/*
* Commands in the OS-interface. Note that many of these are unsafe.
*/
- {"after", Tcl_AfterObjCmd, NULL, 1},
- {"cd", Tcl_CdObjCmd, NULL, 0},
- {"close", Tcl_CloseObjCmd, NULL, 1},
- {"eof", Tcl_EofObjCmd, NULL, 1},
- {"encoding", Tcl_EncodingObjCmd, NULL, 0},
- {"exec", Tcl_ExecObjCmd, NULL, 0},
- {"exit", Tcl_ExitObjCmd, NULL, 0},
- {"fblocked", Tcl_FblockedObjCmd, NULL, 1},
- {"fconfigure", Tcl_FconfigureObjCmd, NULL, 0},
- {"fcopy", Tcl_FcopyObjCmd, NULL, 1},
- {"file", Tcl_FileObjCmd, NULL, 0},
- {"fileevent", Tcl_FileEventObjCmd, NULL, 1},
- {"flush", Tcl_FlushObjCmd, NULL, 1},
- {"gets", Tcl_GetsObjCmd, NULL, 1},
- {"glob", Tcl_GlobObjCmd, NULL, 0},
- {"load", Tcl_LoadObjCmd, NULL, 0},
- {"open", Tcl_OpenObjCmd, NULL, 0},
- {"pid", Tcl_PidObjCmd, NULL, 1},
- {"puts", Tcl_PutsObjCmd, NULL, 1},
- {"pwd", Tcl_PwdObjCmd, NULL, 0},
- {"read", Tcl_ReadObjCmd, NULL, 1},
- {"seek", Tcl_SeekObjCmd, NULL, 1},
- {"socket", Tcl_SocketObjCmd, NULL, 0},
- {"source", Tcl_SourceObjCmd, NULL, 0},
- {"tell", Tcl_TellObjCmd, NULL, 1},
- {"time", Tcl_TimeObjCmd, NULL, 1},
- {"unload", Tcl_UnloadObjCmd, NULL, 0},
- {"update", Tcl_UpdateObjCmd, NULL, 1},
- {"vwait", Tcl_VwaitObjCmd, NULL, 1},
- {NULL, NULL, NULL, 0}
+ {"after", Tcl_AfterObjCmd, NULL, NULL, 1},
+ {"cd", Tcl_CdObjCmd, NULL, NULL, 0},
+ {"close", Tcl_CloseObjCmd, NULL, NULL, 1},
+ {"eof", Tcl_EofObjCmd, NULL, NULL, 1},
+ {"encoding", Tcl_EncodingObjCmd, NULL, NULL, 0},
+ {"exec", Tcl_ExecObjCmd, NULL, NULL, 0},
+ {"exit", Tcl_ExitObjCmd, NULL, NULL, 0},
+ {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, 1},
+ {"fconfigure", Tcl_FconfigureObjCmd, NULL, NULL, 0},
+ {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, 1},
+ {"file", Tcl_FileObjCmd, NULL, NULL, 0},
+ {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, 1},
+ {"flush", Tcl_FlushObjCmd, NULL, NULL, 1},
+ {"gets", Tcl_GetsObjCmd, NULL, NULL, 1},
+ {"glob", Tcl_GlobObjCmd, NULL, NULL, 0},
+ {"load", Tcl_LoadObjCmd, NULL, NULL, 0},
+ {"open", Tcl_OpenObjCmd, NULL, NULL, 0},
+ {"pid", Tcl_PidObjCmd, NULL, NULL, 1},
+ {"puts", Tcl_PutsObjCmd, NULL, NULL, 1},
+ {"pwd", Tcl_PwdObjCmd, NULL, NULL, 0},
+ {"read", Tcl_ReadObjCmd, NULL, NULL, 1},
+ {"seek", Tcl_SeekObjCmd, NULL, NULL, 1},
+ {"socket", Tcl_SocketObjCmd, NULL, NULL, 0},
+ {"source", Tcl_SourceObjCmd, NULL, NULL, 0},
+ {"tell", Tcl_TellObjCmd, NULL, NULL, 1},
+ {"time", Tcl_TimeObjCmd, NULL, NULL, 1},
+ {"unload", Tcl_UnloadObjCmd, NULL, NULL, 0},
+ {"update", Tcl_UpdateObjCmd, NULL, NULL, 1},
+ {"vwait", Tcl_VwaitObjCmd, NULL, NULL, 1},
+ {NULL, NULL, NULL, NULL, 0}
};
/*
@@ -323,46 +357,6 @@ static const OpCmdInfo mathOpCmds[] = {
{0}, NULL}
};
-/*
- * Macros for stack checks. The goal of these macros is to allow the size of
- * the stack to be checked (so preventing overflow) in a *cheap* way. Note
- * that the check needs to be (amortized) cheap since it is on the critical
- * path for recursion.
- */
-
-#if defined(TCL_NO_STACK_CHECK)
-/*
- * Stack check disabled: make them noops.
- */
-
-# define CheckCStack(interp, localIntPtr) 1
-# define GetCStackParams(iPtr) /* do nothing */
-#elif defined(TCL_CROSS_COMPILE)
-
-/*
- * This variable is static and only set *once*, during library initialization.
- * It therefore needs no thread guards.
- */
-
-static int stackGrowsDown = 1;
-# define GetCStackParams(iPtr) \
- stackGrowsDown = TclpGetCStackParams(&((iPtr)->stackBound))
-# define CheckCStack(iPtr, localIntPtr) \
- (stackGrowsDown \
- ? ((localIntPtr) > (iPtr)->stackBound) \
- : ((localIntPtr) < (iPtr)->stackBound) \
- )
-#else /* !TCL_NO_STACK_CHECK && !TCL_CROSS_COMPILE */
-# define GetCStackParams(iPtr) \
- TclpGetCStackParams(&((iPtr)->stackBound))
-# ifdef TCL_STACK_GROWS_UP
-# define CheckCStack(iPtr, localIntPtr) \
- (!(iPtr)->stackBound || (localIntPtr) < (iPtr)->stackBound)
-# else /* TCL_STACK_GROWS_UP */
-# define CheckCStack(iPtr, localIntPtr) \
- ((localIntPtr) > (iPtr)->stackBound)
-# endif /* TCL_STACK_GROWS_UP */
-#endif /* TCL_NO_STACK_CHECK/TCL_CROSS_COMPILE */
/*
* This is the script cancellation struct and hash table. The hash table
@@ -695,13 +689,6 @@ Tcl_CreateInterp(void)
iPtr->asyncReadyPtr = TclGetAsyncReadyPtr();
/*
- * Insure that the stack checking mechanism for this interp is
- * initialized.
- */
-
- GetCStackParams(iPtr);
-
- /*
* Create the core commands. Do it here, rather than calling
* Tcl_CreateCommand, because it's faster (there's no need to check for a
* pre-existing command by the same name). If a command has a Tcl_CmdProc
@@ -736,6 +723,7 @@ Tcl_CreateInterp(void)
cmdPtr->flags = 0;
cmdPtr->importRefPtr = NULL;
cmdPtr->tracePtr = NULL;
+ cmdPtr->nreProc = cmdInfoPtr->nreProc;
Tcl_SetHashValue(hPtr, cmdPtr);
}
}
@@ -779,6 +767,13 @@ Tcl_CreateInterp(void)
Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
Tcl_DisassembleObjCmd, NULL, NULL);
+ /*
+ * Create an unsupported command for tailcalls
+ */
+
+ TclNR_CreateCommand(interp, "::tcl::unsupported::tailcall",
+ /*objProc*/ NULL, TclTailcallObjCmd, NULL, NULL);
+
#ifdef USE_DTRACE
/*
* Register the tcl::dtrace command.
@@ -901,6 +896,7 @@ Tcl_CreateInterp(void)
Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp)));
}
+ TOP_RECORD(iPtr) = NULL;
return interp;
}
@@ -1978,6 +1974,7 @@ Tcl_CreateCommand(
cmdPtr->flags = 0;
cmdPtr->importRefPtr = NULL;
cmdPtr->tracePtr = NULL;
+ cmdPtr->nreProc = NULL;
/*
* Plug in any existing import references found above. Be sure to update
@@ -2149,6 +2146,7 @@ Tcl_CreateObjCommand(
cmdPtr->flags = 0;
cmdPtr->importRefPtr = NULL;
cmdPtr->tracePtr = NULL;
+ cmdPtr->nreProc = NULL;
/*
* Plug in any existing import references found above. Be sure to update
@@ -2557,8 +2555,12 @@ Tcl_SetCommandInfoFromToken(
if (infoPtr->objProc == NULL) {
cmdPtr->objProc = TclInvokeStringCommand;
cmdPtr->objClientData = cmdPtr;
+ cmdPtr->nreProc = NULL;
} else {
- cmdPtr->objProc = infoPtr->objProc;
+ if (infoPtr->objProc != cmdPtr->objProc) {
+ cmdPtr->nreProc = NULL;
+ cmdPtr->objProc = infoPtr->objProc;
+ }
cmdPtr->objClientData = infoPtr->objClientData;
}
cmdPtr->deleteProc = infoPtr->deleteProc;
@@ -3123,7 +3125,7 @@ CancelEvalProc(clientData, interp, code)
*
* This function returns a Tcl_Obj with the full source string for the
* command. This insures that traces get a correct NUL-terminated command
- * string.
+ * string. The Tcl_Obj has refCount==1.
*
*----------------------------------------------------------------------
*/
@@ -3131,18 +3133,41 @@ CancelEvalProc(clientData, interp, code)
static Tcl_Obj *
GetCommandSource(
Interp *iPtr,
- const char *command,
- int numChars,
int objc,
- Tcl_Obj *const objv[])
+ Tcl_Obj *const objv[],
+ int lookup)
{
- if (!command) {
- return Tcl_NewListObj(objc, objv);
- }
- if (command == (char *) -1) {
- command = TclGetSrcInfoForCmd(iPtr, &numChars);
+ Tcl_Obj *objPtr, *obj2Ptr;
+ CmdFrame *cfPtr = iPtr->cmdFramePtr;
+ const char *command = NULL;
+ int numChars;
+
+ objPtr = Tcl_NewListObj(objc, objv);
+ if (lookup && cfPtr) {
+ switch (cfPtr->type) {
+ case TCL_LOCATION_EVAL:
+ case TCL_LOCATION_SOURCE:
+ command = cfPtr->cmd.str.cmd;
+ numChars = cfPtr->cmd.str.len;
+ break;
+ case TCL_LOCATION_BC:
+ case TCL_LOCATION_PREBC:
+ command = TclGetSrcInfoForCmd(iPtr, &numChars);
+ break;
+ case TCL_LOCATION_EVAL_LIST:
+ /* Got it already */
+ break;
+ }
+ if (command) {
+ obj2Ptr = Tcl_NewStringObj(command, numChars);
+ objPtr->bytes = obj2Ptr->bytes;
+ objPtr->length = numChars;
+ obj2Ptr->bytes = NULL;
+ Tcl_DecrRefCount(obj2Ptr);
+ }
}
- return Tcl_NewStringObj(command, numChars);
+ Tcl_IncrRefCount(objPtr);
+ return objPtr;
}
/*
@@ -3294,8 +3319,7 @@ OldMathFuncProc(
* We have a non-numeric argument.
*/
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "argument to math function didn't have numeric value",-1));
+ Tcl_SetResult(interp, "argument to math function didn't have numeric value", TCL_STATIC);
TclCheckBadOctal(interp, Tcl_GetString(valuePtr));
ckfree((char *)args);
return TCL_ERROR;
@@ -3571,7 +3595,6 @@ int
TclInterpReady(
Tcl_Interp *interp)
{
- int localInt; /* used for checking the stack */
register Interp *iPtr = (Interp *) interp;
/*
@@ -3599,18 +3622,12 @@ TclInterpReady(
* probably because of an infinite loop somewhere.
*/
- if (((iPtr->numLevels) <= iPtr->maxNestingDepth)
- && CheckCStack(iPtr, &localInt)) {
+ if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) {
return TCL_OK;
}
- if (!CheckCStack(iPtr, &localInt)) {
- Tcl_AppendResult(interp,
- "out of stack space (infinite loop?)", NULL);
- } else {
- Tcl_AppendResult(interp,
- "too many nested evaluations (infinite loop?)", NULL);
- }
+ Tcl_AppendResult(interp,
+ "too many nested evaluations (infinite loop?)", NULL);
return TCL_ERROR;
}
@@ -3871,20 +3888,14 @@ Tcl_CancelEval(
/*
*----------------------------------------------------------------------
*
- * TclEvalObjvInternal
+ * Tcl_EvalObjv --
*
* This function evaluates a Tcl command that has already been parsed
- * into words, with one Tcl_Obj holding each word. The caller is
- * responsible for managing the iPtr->numLevels.
- *
- * TclEvalObjvInternal is the backend for Tcl_EvalObjv, the bytecode
- * engine also calls it directly.
+ * into words, with one Tcl_Obj holding each word.
*
* Results:
* The return value is a standard Tcl completion code such as TCL_OK or
- * TCL_ERROR. A result or error message is left in interp's result. If an
- * error occurs, this function does NOT add any information to the
- * errorInfo variable.
+ * TCL_ERROR. A result or error message is left in interp's result.
*
* Side effects:
* Depends on the command.
@@ -3893,96 +3904,78 @@ Tcl_CancelEval(
*/
int
-TclEvalObjvInternal(
+Tcl_EvalObjv(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* command. Also used for error reporting. */
int objc, /* Number of words in command. */
Tcl_Obj *const objv[], /* An array of pointers to objects that are
* the words that make up the command. */
- const char *command, /* Points to the beginning of the string
- * representation of the command; this is used
- * for traces. NULL if the string
- * representation of the command is unknown is
- * to be generated from (objc,objv), -1 if it
- * is to be generated from bytecode
- * source. This is only needed the traces. */
- int length, /* Number of bytes in command; if -1, all
- * characters up to the first null byte are
- * used. */
int flags) /* Collection of OR-ed bits that control the
* evaluation of the script. Only
- * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are
- * currently supported. */
+ * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
+ * TCL_EVAL_NOERR are currently supported. */
{
Command *cmdPtr;
Interp *iPtr = (Interp *) interp;
- Tcl_Obj **newObjv;
- int i;
- CallFrame *savedVarFramePtr = NULL;
- CallFrame *varFramePtr = iPtr->varFramePtr;
- int code = TCL_OK;
- int traceCode = TCL_OK;
- int checkTraces = 1, traced;
- Namespace *savedNsPtr = NULL;
- Namespace *lookupNsPtr = iPtr->lookupNsPtr;
- Tcl_Obj *commandPtr = NULL;
+ int result;
+ Namespace *lookupNsPtr;
- if (TclInterpReady(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
+ TEOV_record *rootPtr = TOP_RECORD(iPtr);
+ TEOV_record *recordPtr;
+
+ Tcl_ObjCmdProc *objProc;
+ ClientData objClientData;
+ int tebcCall = TEBC_CALL(iPtr);
- if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
- return TCL_ERROR;
+ TEBC_CALL(iPtr) = 0;
+
+ restartAtTop:
+ iPtr->numLevels++;
+ result = TclInterpReady(interp);
+
+ if (result == TCL_OK) {
+ result = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG);
}
- if (objc == 0) {
- return TCL_OK;
+ if ((result != TCL_OK) || (objc == 0)) {
+ iPtr->lookupNsPtr = NULL;
+ iPtr->numLevels--;
+ goto done;
}
/*
- * If any execution traces rename or delete the current command, we may
- * need (at most) two passes here.
+ * Always push a record for the command (avoid queuing callbacks for an
+ * older command!)
*/
- reparseBecauseOfTraces:
-
+ PUSH_RECORD(interp, recordPtr);
+
/*
- * Configure evaluation context to match the requested flags.
+ * Push records for task to be done on return, in INVERSE order. First, if
+ * needed, the exception handlers (as they should happen last).
*/
-
- if (flags) {
- if (flags & TCL_EVAL_INVOKE) {
- savedNsPtr = varFramePtr->nsPtr;
- if (lookupNsPtr) {
- varFramePtr->nsPtr = lookupNsPtr;
- iPtr->lookupNsPtr = NULL;
- } else {
- varFramePtr->nsPtr = iPtr->globalNsPtr;
- }
- } else if ((flags & TCL_EVAL_GLOBAL)
- && (varFramePtr != iPtr->rootFramePtr) && !savedVarFramePtr) {
- varFramePtr = iPtr->rootFramePtr;
- savedVarFramePtr = iPtr->varFramePtr;
- iPtr->varFramePtr = varFramePtr;
- }
+
+ if (!(flags & TCL_EVAL_NOERR)) {
+ TEOV_PushExceptionHandlers(interp, objc, objv, flags);
}
/*
- * Find the function to execute this command. If there isn't one, then see
- * if there is an unknown command handler registered for this namespace.
- * If so, create a new word array with the handler as the first words and
- * the original command words as arguments. Then call ourselves
- * recursively to execute it.
+ * Configure evaluation context to match the requested flags.
*/
- cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
- if (!cmdPtr) {
- goto notFound;
- }
+ lookupNsPtr = iPtr->lookupNsPtr;
+ if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) {
+ if (!lookupNsPtr) {
+ lookupNsPtr = iPtr->globalNsPtr;
+ } else {
+ iPtr->lookupNsPtr = NULL;
+ }
+ } else {
+ if (flags & TCL_EVAL_GLOBAL) {
+ TEOV_SwitchVarFrame(interp);
+ lookupNsPtr = iPtr->globalNsPtr;
+ }
- if (savedNsPtr) {
- varFramePtr->nsPtr = savedNsPtr;
- } else if (iPtr->ensembleRewrite.sourceObjs) {
/*
* TCL_EVAL_INVOKE was not set: clear rewrite rules
*/
@@ -3990,57 +3983,38 @@ TclEvalObjvInternal(
iPtr->ensembleRewrite.sourceObjs = NULL;
}
+
/*
- * Call trace functions if needed.
+ * Lookup the command
*/
+
+ cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr);
+ if (!cmdPtr) {
+ notFound:
+ result = TEOV_NotFound(interp, objc, objv, lookupNsPtr);
+ iPtr->numLevels--;
+ goto done;
+ }
- traced = (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES));
- if (traced && checkTraces) {
- int cmdEpoch = cmdPtr->cmdEpoch;
- int newEpoch;
-
- /*
- * Insure that we have a correct nul-terminated command string for the
- * trace code.
- */
-
- commandPtr = GetCommandSource(iPtr, command, length, objc, objv);
- command = TclGetStringFromObj(commandPtr, &length);
-
+ if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
/*
- * Execute any command or execution traces. Note that we bump up the
- * command's reference count for the duration of the calling of the
- * traces so that the structure doesn't go away underneath our feet.
+ * Call enter traces. They will schedule a call to the leave traces if
+ * necessary.
*/
- cmdPtr->refCount++;
- if (iPtr->tracePtr && (traceCode == TCL_OK)) {
- traceCode = TclCheckInterpTraces(interp, command, length,
- cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
+ result = TEOV_RunEnterTraces(interp, &cmdPtr, objc, objv, lookupNsPtr);
+ if (!cmdPtr) {
+ goto notFound;
}
- if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
- traceCode = TclCheckExecutionTraces(interp, command, length,
- cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
- }
- newEpoch = cmdPtr->cmdEpoch;
- TclCleanupCommandMacro(cmdPtr);
-
- /*
- * If the traces modified/deleted the command or any existing traces,
- * they will update the command's epoch. When that happens, set
- * checkTraces is set to 0 to prevent the re-calling of traces (and
- * any possible infinite loop) and we go back to re-find the command
- * implementation.
- */
-
- if (cmdEpoch != newEpoch) {
- checkTraces = 0;
- if (commandPtr) {
- Tcl_DecrRefCount(commandPtr);
- }
- goto reparseBecauseOfTraces;
+ if (result != TCL_OK) {
+ iPtr->numLevels--;
+ goto done;
}
}
+
+ /*
+ * Found a command! The real work begins now ...
+ */
if (TCL_DTRACE_CMD_ARGS_ENABLED()) {
char *a[10];
@@ -4063,260 +4037,608 @@ TclEvalObjvInternal(
/*
* Finally, invoke the command's Tcl_ObjCmdProc.
+ *
+ * Do the NR dance right here:
+ * - for non-NR enabled commands, just sigh and call the objProc
+ * - for NR-enabled commands call the part1, decide what to do with
+ * the continuation:
+ * . if it is a bytecode AND we were called by TEBC, pass it
+ * back. Otherwise just call a new TEBC on it. Don't register
+ * the callback, TEBC handles those.
+ * . if it is a command and it has a callback, push the callback
+ * into the TODO list, set the params as needed and restart at
+ * the top.
+ *
+ * Note that I removed the DTRACE thing: I have not really thought
+ * about where it really belongs, and do not really know what it does
+ * either.
*/
- cmdPtr->refCount++;
iPtr->cmdCount++;
- if (code == TCL_OK && traceCode == TCL_OK
- && !TclLimitExceeded(iPtr->limit)) {
- if (TCL_DTRACE_CMD_ENTRY_ENABLED()) {
- TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1,
- (Tcl_Obj **)(objv + 1));
- }
- code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
- if (TCL_DTRACE_CMD_RETURN_ENABLED()) {
- TCL_DTRACE_CMD_RETURN(TclGetString(objv[0]), code);
- }
+ if (TclLimitExceeded(iPtr->limit)) {
+ result = TCL_ERROR;
+ iPtr->numLevels--;
+ goto done;
}
- if (TclAsyncReady(iPtr)) {
- code = Tcl_AsyncInvoke(interp, code);
- }
- if (code == TCL_OK && Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
- code = TCL_ERROR;
- }
- if (code == TCL_OK && TclLimitReady(iPtr->limit)) {
- code = Tcl_LimitCheck(interp);
+ objProc = cmdPtr->nreProc;
+ if (!objProc) {
+ objProc = cmdPtr->objProc;
}
-
+ objClientData = cmdPtr->objClientData;
+
+ COMPLETE_RECORD(recordPtr);
+ cmdPtr->refCount++;
+
+ objProcReentryPoint:
/*
- * Call 'leave' command traces
+ * If this is an NR-enabled command, find the real objProc.
*/
- if (traced) {
- if (!(cmdPtr->flags & CMD_IS_DELETED)) {
- if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){
- traceCode = TclCheckExecutionTraces(interp, command, length,
- cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
+ result = (*objProc)(objClientData, interp, objc, objv);
+ if ((result != TCL_OK) || !VALID_NEW_REQUEST(recordPtr)) {
+#if 0
+ TclStackPurge(interp, recordPtr->tosPtr);
+#endif
+ goto done;
+ }
+
+ /*
+ * We got a valid callback request: let us complete the corresponding
+ * record and proceed with the next call.
+ */
+
+ switch(recordPtr->type) {
+ case TCL_NR_NO_TYPE: {
+ break;
+ }
+ case TCL_NR_BC_TYPE: {
+ tcl_nr_bc_type:
+ if (USE_NR_TEBC && tebcCall) {
+ /*
+ * We were called by TEBC, and we need a bytecode to be
+ * executed: just ask our caller to do that.
+ * TEBC_CALL(iPtr) = TEBC_DO_EXEC = 0 is not really needed, as
+ * it is already 0==TEBC_DO_EXEC
+ */
+
+ TEBC_CALL(iPtr) = TEBC_DO_EXEC;
+ TEBC_DATA(iPtr) = recordPtr->data.codePtr;
+ return TCL_OK;
}
- if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
- traceCode = TclCheckInterpTraces(interp, command, length,
- cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
+
+ /*
+ * No TEBC atop - we'll just have to instantiate a new one and
+ * do the callback on return.
+ */
+
+ result = TclExecuteByteCode(interp, recordPtr->data.codePtr);
+ goto done;
+ }
+ case TCL_NR_TAILCALL_TYPE: {
+ /*
+ * Got to save this record, free the stack (ie, perform all
+ * pending callbacks) and restore the record.
+ */
+
+ Tcl_Obj *tailObjPtr = recordPtr->data.obj.objPtr;
+
+ result = TclEvalObjv_NR2(interp, result, rootPtr);
+
+ if (result != TCL_OK) {
+ goto done;
}
+ if (USE_NR_TEBC && tebcCall) {
+ /*
+ * We were called by TEBC, and we need it to drop a frame: let
+ * him know.
+ */
+
+ TEBC_CALL(iPtr) = TEBC_DO_TAILCALL;
+ TEBC_DATA(iPtr) = tailObjPtr;
+ return TCL_OK;
+ }
+
+ /*
+ * ONLY supported if called from TEBC. Could do an 'uplevel 1'?
+ * Run from here (as hinted below)? Mmhhh ... FIXME. Maybe
+ * tailcalls SHOULD actually be bytecompiled (we know how to more
+ * or less fake it when falling off TEBC)?
+ */
+
+ Tcl_Panic("tailcall called from a non-compiled command?");
+ /* FALL THROUGH */
}
+ case TCL_NR_CMD_TYPE: {
+ /*
+ * We got an unshared canonical list to eval , do it from here.
+ */
- /*
- * If one of the trace invocation resulted in error, then change the
- * result code accordingly. Note, that the interp->result should
- * already be set correctly by the call to TraceExecutionProc.
- */
+ Tcl_Obj *objPtr = recordPtr->data.obj.objPtr;
+ Tcl_Obj **elemPtr;
- if (traceCode != TCL_OK) {
- code = traceCode;
+ flags = recordPtr->data.obj.flags;
+ Tcl_ListObjGetElements(NULL, objPtr, &objc, &elemPtr);
+ objv = elemPtr;
+ if (objc == 0) {
+ goto done;
+ }
+ goto restartAtTop;
+ }
+ case TCL_NR_SCRIPT_TYPE: {
+ Tcl_Obj *objPtr = recordPtr->data.obj.objPtr;
+
+ flags = recordPtr->data.obj.flags;
+ if (USE_NR_TEBC && tebcCall) {
+ result = TclNREvalObjEx(interp, objPtr, flags, NULL, 0);
+ if (result == TCL_OK) {
+ switch (recordPtr->type) {
+ case TCL_NR_BC_TYPE:
+ goto tcl_nr_bc_type;
+ case TCL_NR_NO_TYPE:
+ goto done;
+ default:
+ Tcl_Panic("TEOEx called from TEOV returns unexpected record type");
+ }
+ }
+ goto done;
+ } else {
+ result = TclEvalObjEx(interp, objPtr, flags, NULL, 0);
+ goto done;
+ }
}
- if (commandPtr) {
- Tcl_DecrRefCount(commandPtr);
+ case TCL_NR_OBJPROC_TYPE: {
+ /* This is a rewrite like ns-import does, without a new
+ * cmdPtr or new reentrant call. FIXME: add the possibility of a
+ * new callback (TclNR_ObjProc has that), and maybe also edition
+ * of objc/objv? */
+
+ objProc = recordPtr->data.objProc.objProc;
+ objClientData = recordPtr->data.objProc.clientData;
+ recordPtr->type = TCL_NR_NO_TYPE;
+ goto objProcReentryPoint;
+ }
+ default: {
+ Tcl_Panic("TEOV: unknown NR-request type %i!", recordPtr->type);
}
}
+ done:
+ return TclEvalObjv_NR2(interp, result, rootPtr);
+}
- /*
- * Decrement the reference count of cmdPtr and deallocate it if it has
- * dropped to zero.
- */
-
- TclCleanupCommandMacro(cmdPtr);
+int TclEvalObjv_NR2(
+ Tcl_Interp *interp,
+ int result,
+ struct TEOV_record *rootPtr)
+{
+ Interp *iPtr = (Interp *) interp;
+ TEOV_record *recordPtr;
/*
* If the interpreter has a non-empty string result, the result object is
* either empty or stale because some function set interp->result
* directly. If so, move the string result to the result object, then
* reset the string result.
+ *
+ * This only needs to be done for the first item in the list: all other
+ * are for NR function calls, and those are Tcl_Obj based.
*/
if (*(iPtr->result) != 0) {
(void) Tcl_GetObjResult(interp);
}
- if (TCL_DTRACE_CMD_RESULT_ENABLED()) {
- Tcl_Obj *r;
+ TclResetCancellation(interp, 0);
- r = Tcl_GetObjResult(interp);
- TCL_DTRACE_CMD_RESULT(TclGetString(objv[0]), code, TclGetString(r),r);
- }
+ while (TOP_RECORD(iPtr) != rootPtr) {
+ POP_RECORD(iPtr, recordPtr);
- done:
- if (savedVarFramePtr) {
- iPtr->varFramePtr = savedVarFramePtr;
- }
- return code;
+ while (recordPtr->callbackPtr) {//
+ TEOV_callback *callbackPtr = recordPtr->callbackPtr;
+ result = (*callbackPtr->procPtr)(&callbackPtr->data0,
+ interp, result);
+ callbackPtr = callbackPtr->nextPtr;
+ TclSmallFree(recordPtr->callbackPtr);
+ recordPtr->callbackPtr = callbackPtr;
+ }
- notFound:
- {
- Namespace *currNsPtr = NULL; /* Used to check for and invoke any
- * registered unknown command handler
- * for the current namespace (TIP
- * 181). */
- int newObjc, handlerObjc;
- Tcl_Obj **handlerObjv;
-
- currNsPtr = varFramePtr->nsPtr;
- if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) {
- currNsPtr = iPtr->globalNsPtr;
- if (currNsPtr == NULL) {
- Tcl_Panic("TclEvalObjvInternal: NULL global namespace pointer");
- }
+ if (!CHECK_EXTRA(iPtr, recordPtr)) {
+ Tcl_Panic("TclEvalObjv_NR2: wrong tosPtr?");
+ /* TclStackPurge(interp, recordPtr->tosPtr); */
}
/*
- * Check to see if the resolution namespace has lost its unknown
- * handler. If so, reset it to "::unknown".
+ * Decrement the reference count of cmdPtr and deallocate it if it has
+ * dropped to zero. The level only needs fixing for records that
+ * pushed a cmdPtr.
*/
- if (currNsPtr->unknownHandlerPtr == NULL) {
- TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown");
- Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr);
+ if (recordPtr->cmdPtr) {
+ TclCleanupCommandMacro(recordPtr->cmdPtr);
+ iPtr->numLevels--;
}
- /*
- * Get the list of words for the unknown handler and allocate enough
- * space to hold both the handler prefix and all words of the command
- * invokation itself.
- */
+ if (TCL_DTRACE_CMD_RETURN_ENABLED()) {
+ TCL_DTRACE_CMD_RETURN(TclGetString(objv[0]), result);
+ }
+
+ FREE_RECORD(iPtr, recordPtr);
+ }
+
+ /*
+ * Do not interrupt a series of cleanups with async or limit checks: just
+ * check at the end.
+ */
+
+ if (TclAsyncReady(iPtr)) {
+ result = Tcl_AsyncInvoke(interp, result);
+ }
+
+ if (result == TCL_OK) {
+ result = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG);
+ }
+
+ if (result == TCL_OK && TclLimitReady(iPtr->limit)) {
+ result = Tcl_LimitCheck(interp);
+ }
+
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TEOV_Exception -
+ * TEOV_LookupCmdFromObj -
+ * TEOV_RunEnterTraces -
+ * TEOV_RunLeaveTraces -
+ * TEOV_NotFound -
+ *
+ * These are helper functions for Tcl_EvalObjv.
+ *
+ *----------------------------------------------------------------------
+ */
- Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
- &handlerObjc, &handlerObjv);
- newObjc = objc + handlerObjc;
- newObjv = (Tcl_Obj **) TclStackAlloc(interp,
- (int) sizeof(Tcl_Obj *) * newObjc);
+static void
+TEOV_PushExceptionHandlers(
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[],
+ int flags)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ /*
+ * If any error processing is necessary, push the appropriate
+ * records. Note that we have to push them in the inverse order: first
+ * the one that has to run last.
+ */
+ if (!(flags & TCL_EVAL_INVOKE)) {
/*
- * Copy command prefix from unknown handler and add on the real
- * command's full argument list. Note that we only use memcpy() once
- * because we have to increment the reference count of all the handler
- * arguments anyway.
+ * Error messages
*/
+
+ TclNR_AddCallback(interp, TEOV_Error, INT2PTR(objc), (ClientData) objv,
+ NULL, NULL);
+ }
+
+ if (iPtr->numLevels == 1) {
+ /*
+ * No CONTINUE or BREAK at level 0, manage RETURN
+ */
+
+ TclNR_AddCallback(interp, TEOV_Exception, NULL, NULL, NULL, NULL);
+ }
+}
- for (i = 0; i < handlerObjc; ++i) {
- newObjv[i] = handlerObjv[i];
- Tcl_IncrRefCount(newObjv[i]);
+static void
+TEOV_SwitchVarFrame(
+ Tcl_Interp *interp)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ /*
+ * Change the varFrame to be the rootVarFrame, and push a record
+ * to restore things at the end.
+ */
+
+ TclNR_AddCallback(interp, TEOV_RestoreVarFrame, iPtr->varFramePtr, NULL, NULL, NULL);
+ iPtr->varFramePtr = iPtr->rootFramePtr;
+}
+
+static int
+TEOV_RestoreVarFrame(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ ((Interp *) interp)->varFramePtr = data[0];
+ return result;
+}
+
+static int
+TEOV_Exception(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
+
+ if (result != TCL_OK) {
+ if (result == TCL_RETURN) {
+ result = TclUpdateReturnInfo(iPtr);
+ }
+ if ((result != TCL_ERROR) && !allowExceptions) {
+ ProcessUnexpectedResult(interp, result);
+ result = TCL_ERROR;
}
- memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc);
+ }
+ return result;
+}
+static int
+TEOV_Error(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *listPtr;
+ char *cmdString;
+ int cmdLen;
+ int objc = PTR2INT(data[0]);
+ Tcl_Obj **objv = data[1];
+
+ if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)){
/*
- * Look up and invoke the handler (by recursive call to this
- * function). If there is no handler at all, instead of doing the
- * recursive call we just generate a generic error message; it would
- * be an infinite-recursion nightmare otherwise.
+ * If there was an error, a command string will be needed for the
+ * error log: get it out of the itemPtr. The details depend on the
+ * type
*/
- cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
- if (cmdPtr == NULL) {
- Tcl_AppendResult(interp, "invalid command name \"",
- TclGetString(objv[0]), "\"", NULL);
- code = TCL_ERROR;
- } else {
- TclResetCancellation(interp, 0);
+ listPtr = Tcl_NewListObj(objc, objv);
+ cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen);
+ Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
+ Tcl_DecrRefCount(listPtr);
+ }
+ iPtr->flags &= ~ERR_ALREADY_LOGGED;
+ return result;
+}
- iPtr->numLevels++;
- code = TclEvalObjvInternal(interp, newObjc, newObjv, command,
- length, 0);
- iPtr->numLevels--;
+static int
+TEOV_NotFound(
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[],
+ Namespace *lookupNsPtr)
+{
+ Command * cmdPtr;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj **newObjv;
+ int i;
+ CallFrame *varFramePtr = iPtr->varFramePtr;
+ int result = TCL_OK;
+ Namespace *currNsPtr = NULL; /* Used to check for and invoke any
+ * registered unknown command handler
+ * for the current namespace (TIP
+ * 181). */
+ int newObjc, handlerObjc;
+ Tcl_Obj **handlerObjv;
+ Namespace *savedNsPtr = NULL;
+
+ currNsPtr = varFramePtr->nsPtr;
+ if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) {
+ currNsPtr = iPtr->globalNsPtr;
+ if (currNsPtr == NULL) {
+ Tcl_Panic("Tcl_EvalObjv: NULL global namespace pointer");
}
+ }
- /*
- * Release any resources we locked and allocated during the handler
- * call.
- */
+ /*
+ * Check to see if the resolution namespace has lost its unknown
+ * handler. If so, reset it to "::unknown".
+ */
- for (i = 0; i < handlerObjc; ++i) {
- Tcl_DecrRefCount(newObjv[i]);
+ if (currNsPtr->unknownHandlerPtr == NULL) {
+ TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown");
+ Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr);
+ }
+
+ /*
+ * Get the list of words for the unknown handler and allocate enough
+ * space to hold both the handler prefix and all words of the command
+ * invokation itself.
+ */
+
+ Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
+ &handlerObjc, &handlerObjv);
+ newObjc = objc + handlerObjc;
+ newObjv = (Tcl_Obj **) TclStackAlloc(interp,
+ (int) sizeof(Tcl_Obj *) * newObjc);
+
+ /*
+ * Copy command prefix from unknown handler and add on the real
+ * command's full argument list. Note that we only use memcpy() once
+ * because we have to increment the reference count of all the handler
+ * arguments anyway.
+ */
+
+ for (i = 0; i < handlerObjc; ++i) {
+ newObjv[i] = handlerObjv[i];
+ Tcl_IncrRefCount(newObjv[i]);
+ }
+ memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc);
+
+ /*
+ * Look up and invoke the handler (by recursive call to this
+ * function). If there is no handler at all, instead of doing the
+ * recursive call we just generate a generic error message; it would
+ * be an infinite-recursion nightmare otherwise.
+ *
+ * In this case we worry a bit less about recursion for now, and call
+ * the "blocking" interface.
+ */
+
+ cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr);
+ if (cmdPtr == NULL) {
+ Tcl_AppendResult(interp, "invalid command name \"",
+ TclGetString(objv[0]), "\"", NULL);
+ result = TCL_ERROR;
+ } else {
+ if (lookupNsPtr) {
+ savedNsPtr = varFramePtr->nsPtr;
+ varFramePtr->nsPtr = lookupNsPtr;
}
- TclStackFree(interp, newObjv);
+ result = Tcl_EvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR);
if (savedNsPtr) {
varFramePtr->nsPtr = savedNsPtr;
}
- goto done;
}
+
+ /*
+ * Release any resources we locked and allocated during the handler
+ * call.
+ */
+
+ for (i = 0; i < handlerObjc; ++i) {
+ Tcl_DecrRefCount(newObjv[i]);
+ }
+ TclStackFree(interp, newObjv);
+ return result;
}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_EvalObjv --
- *
- * This function evaluates a Tcl command that has already been parsed
- * into words, with one Tcl_Obj holding each word.
- *
- * Results:
- * The return value is a standard Tcl completion code such as TCL_OK or
- * TCL_ERROR. A result or error message is left in interp's result.
- *
- * Side effects:
- * Depends on the command.
- *
- *----------------------------------------------------------------------
- */
-int
-Tcl_EvalObjv(
- Tcl_Interp *interp, /* Interpreter in which to evaluate the
- * command. Also used for error reporting. */
- int objc, /* Number of words in command. */
- Tcl_Obj *const objv[], /* An array of pointers to objects that are
- * the words that make up the command. */
- int flags) /* Collection of OR-ed bits that control the
- * evaluation of the script. Only
- * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are
- * currently supported. */
+static int
+TEOV_RunEnterTraces(
+ Tcl_Interp *interp,
+ Command **cmdPtrPtr,
+ int objc,
+ Tcl_Obj *const objv[],
+ Namespace *lookupNsPtr)
{
Interp *iPtr = (Interp *) interp;
- int code = TCL_OK;
-
- TclResetCancellation(interp, 0);
-
- iPtr->numLevels++;
- code = TclEvalObjvInternal(interp, objc, objv, NULL, 0, flags);
- iPtr->numLevels--;
-
- if (code == TCL_OK) {
- return code;
- } else {
- int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
+ Command *cmdPtr = *cmdPtrPtr;
+ int traceCode = TCL_OK;
+ int cmdEpoch = cmdPtr->cmdEpoch;
+ int newEpoch;
+ char *command;
+ int length;
+ Tcl_Obj *commandPtr;
+
+ commandPtr = GetCommandSource(iPtr, objc, objv, 1);
+ command = Tcl_GetStringFromObj(commandPtr, &length);
+
+ /*
+ * Call trace functions
+ * Execute any command or execution traces. Note that we bump up the
+ * command's reference count for the duration of the calling of the
+ * traces so that the structure doesn't go away underneath our feet.
+ */
+
+ cmdPtr->refCount++;
+ if (iPtr->tracePtr) {
+ traceCode = TclCheckInterpTraces(interp, command, length,
+ cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv);
+ }
+ if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
+ traceCode = TclCheckExecutionTraces(interp, command, length,
+ cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv);
+ }
+ newEpoch = cmdPtr->cmdEpoch;
+ TclCleanupCommandMacro(cmdPtr);
+
+ /*
+ * If the traces modified/deleted the command or any existing traces,
+ * they will update the command's epoch. We need to lookup again, but do
+ * not run enter traces on the newly found cmdPtr.
+ */
+
+ if (cmdEpoch != newEpoch) {
+ cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr);
+ *cmdPtrPtr = cmdPtr;
+ }
+ if (cmdPtr) {
/*
- * If we are again at the top level, process any unusual return code
- * returned by the evaluated code.
+ * Command was found: push a record to schedule
+ * the leave traces.
*/
+
+ TclNR_AddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(traceCode),
+ commandPtr, cmdPtr, NULL);
+ cmdPtr->refCount++;
+ } else {
+ Tcl_DecrRefCount(commandPtr);
+ }
+ return traceCode;
+}
- if (iPtr->numLevels == 0) {
- if (code == TCL_RETURN) {
- code = TclUpdateReturnInfo(iPtr);
- }
- if ((code != TCL_ERROR) && !allowExceptions) {
- ProcessUnexpectedResult(interp, code);
- code = TCL_ERROR;
- }
+static int
+TEOV_RunLeaveTraces(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ TclResetCancellation(interp, 0);
+ char *command;
+ int length, objc;
+ Tcl_Obj **objv;
+ int traceCode = PTR2INT(data[0]);
+ Tcl_Obj *commandPtr = data[1];
+ Command *cmdPtr = data[2];
+
+ command = Tcl_GetStringFromObj(commandPtr, &length);
+ if (TCL_OK != Tcl_ListObjGetElements(interp, commandPtr, &objc, &objv)) {
+ Tcl_Panic("Who messed with commandPtr?");
+ }
+
+ if (!(cmdPtr->flags & CMD_IS_DELETED)) {
+ if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){
+ traceCode = TclCheckExecutionTraces(interp, command, length,
+ cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
+ }
+ if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
+ traceCode = TclCheckInterpTraces(interp, command, length,
+ cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
+ }
+ Tcl_DecrRefCount(commandPtr);
- if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) {
- /*
- * If there was an error, a command string will be needed for the
- * error log: generate it now. Do not worry too much about doing
- * it expensively.
- */
+ /*
+ * As cmdPtr is set, TclEvalObjv_NR2 is about to reduce the
+ * numlevels. Prevent that by resetting the cmdPtr field and dealing right
+ * here with cmdPtr->refCount.
+ */
- Tcl_Obj *listPtr;
- char *cmdString;
- int cmdLen;
+ TclCleanupCommandMacro(cmdPtr);
- listPtr = Tcl_NewListObj(objc, objv);
- cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen);
- Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
- Tcl_DecrRefCount(listPtr);
- }
+ if (traceCode != TCL_OK) {
+ return traceCode;
+ } else {
+ return result;
+ }
+}
- return code;
+static inline Command *
+TEOV_LookupCmdFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *namePtr,
+ Namespace *lookupNsPtr)
+{
+ Interp *iPtr = (Interp *) interp;
+ Command *cmdPtr;
+ Namespace *savedNsPtr = iPtr->varFramePtr->nsPtr;
+
+ if (lookupNsPtr) {
+ iPtr->varFramePtr->nsPtr = lookupNsPtr;
+ iPtr->lookupNsPtr = NULL;
}
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr);
+ iPtr->varFramePtr->nsPtr = savedNsPtr;
+ return cmdPtr;
}
/*
@@ -4729,10 +5051,7 @@ TclEvalEx(
TclResetCancellation(interp, 0);
- iPtr->numLevels++;
- code = TclEvalObjvInternal(interp, objectsUsed, objv,
- parsePtr->commandStart, parsePtr->commandSize, 0);
- iPtr->numLevels--;
+ code = Tcl_EvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR);
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
eeFramePtr->line = NULL;
@@ -5004,12 +5323,36 @@ TclEvalObjEx(
const CmdFrame *invoker, /* Frame of the command doing the eval. */
int word) /* Index of the word which is in objPtr. */
{
+ int result = TCL_OK;
+ TEOV_record *recordPtr;
+
+ /*
+ * Push an empty record. If this is an NR call, it will modify it
+ * accordingly.
+ */
+
+ PUSH_RECORD(interp, recordPtr);
+ result = TclNREvalObjEx(interp, objPtr, flags, invoker, word);
+ assert((TOP_RECORD(interp) == recordPtr));
+ return NRPostProcess(interp, result, 0, NULL);
+}
+
+int
+TclNREvalObjEx(
+ Tcl_Interp *interp, /* Token for command interpreter (returned by
+ * a previous call to Tcl_CreateInterp). */
+ register Tcl_Obj *objPtr, /* Pointer to object containing commands to
+ * execute. */
+ int flags, /* Collection of OR-ed bits that control the
+ * evaluation of the script. Supported values
+ * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */
+ const CmdFrame *invoker, /* Frame of the command doing the eval. */
+ int word) /* Index of the word which is in objPtr. */
+{
register Interp *iPtr = (Interp *) interp;
char *script;
int numSrcBytes;
int result;
- CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case
- * TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
Tcl_IncrRefCount(objPtr);
@@ -5056,7 +5399,6 @@ TclEvalObjEx(
ckalloc(eoFramePtr->nline * sizeof(int));
eoFramePtr->cmd.listPtr = objPtr;
- Tcl_IncrRefCount(eoFramePtr->cmd.listPtr);
eoFramePtr->data.eval.path = NULL;
/*
@@ -5072,155 +5414,201 @@ TclEvalObjEx(
}
iPtr->cmdFramePtr = eoFramePtr;
- result = Tcl_EvalObjv(interp, eoFramePtr->nline, elements,
- flags);
-
- Tcl_DecrRefCount(copyPtr);
- iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
- Tcl_DecrRefCount(eoFramePtr->cmd.listPtr);
- ckfree((char *) eoFramePtr->line);
- eoFramePtr->line = NULL;
- eoFramePtr->nline = 0;
- TclStackFree(interp, eoFramePtr);
-
- goto done;
+
+ TclNR_AddCallback(interp, TEOEx_ListCallback, objPtr, eoFramePtr,
+ copyPtr, NULL);
+ return TclNR_EvalObj(interp, objPtr, flags);
}
}
- if (flags & TCL_EVAL_DIRECT) {
+ if (!(flags & TCL_EVAL_DIRECT)) {
/*
- * We're not supposed to use the compiler or byte-code interpreter.
- * Let Tcl_EvalEx evaluate the command directly (and probably more
- * slowly).
- *
- * TIP #280. Propagate context as much as we can. Especially if the
- * script to evaluate is a single literal it makes sense to look if
- * our context is one with absolute line numbers we can then track
- * into the literal itself too.
+ * Let the compiler/engine subsystem do the evaluation.
*
- * See also tclCompile.c, TclInitCompileEnv, for the equivalent code
- * in the bytecode compiler.
+ * TIP #280 The invoker provides us with the context for the script.
+ * We transfer this to the byte code compiler.
*/
- if (invoker == NULL) {
+ ByteCode *newCodePtr;
+ CallFrame *savedVarFramePtr = NULL;
+ /* Saves old copy of iPtr->varFramePtr in
+ * case TCL_EVAL_GLOBAL was set. */
+
+ if (flags & TCL_EVAL_GLOBAL) {
+ savedVarFramePtr = iPtr->varFramePtr;
+ iPtr->varFramePtr = iPtr->rootFramePtr;
+ }
+ TclNR_AddCallback(interp, TEOEx_ByteCodeCallback, savedVarFramePtr,
+ objPtr, INT2PTR(allowExceptions), NULL);
+
+ newCodePtr = TclCompileObj(interp, objPtr, invoker, word);
+ if (newCodePtr) {
+ TEOV_record *recordPtr = TOP_RECORD(interp);
+
+ recordPtr->type = TCL_NR_BC_TYPE;
+ recordPtr->data.codePtr = newCodePtr;
+ return TCL_OK;
+ } else {
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * We're not supposed to use the compiler or byte-code interpreter.
+ * Let Tcl_EvalEx evaluate the command directly (and probably more
+ * slowly).
+ *
+ * TIP #280. Propagate context as much as we can. Especially if the
+ * script to evaluate is a single literal it makes sense to look if
+ * our context is one with absolute line numbers we can then track
+ * into the literal itself too.
+ *
+ * See also tclCompile.c, TclInitCompileEnv, for the equivalent code
+ * in the bytecode compiler.
+ */
+
+ if (invoker == NULL) {
+ /*
+ * No context, force opening of our own.
+ */
+
+ script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
+ } else {
+ /*
+ * We have an invoker, describing the command asking for the
+ * evaluation of a subordinate script. This script may originate
+ * in a literal word, or from a variable, etc. Using the line
+ * array we now check if we have good line information for the
+ * relevant word. The type of context is relevant as well. In a
+ * non-'source' context we don't have to try tracking lines.
+ *
+ * First see if the word exists and is a literal. If not we go
+ * through the easy dynamic branch. No need to perform more
+ * complex invokations.
+ */
+
+ if ((invoker->nline <= word) || (invoker->line[word] < 0)) {
/*
- * No context, force opening of our own.
+ * Dynamic script, or dynamic context, force our own
+ * context.
*/
-
+
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
+
} else {
/*
- * We have an invoker, describing the command asking for the
- * evaluation of a subordinate script. This script may originate
- * in a literal word, or from a variable, etc. Using the line
- * array we now check if we have good line information for the
- * relevant word. The type of context is relevant as well. In a
- * non-'source' context we don't have to try tracking lines.
- *
- * First see if the word exists and is a literal. If not we go
- * through the easy dynamic branch. No need to perform more
- * complex invokations.
+ * Try to get an absolute context for the evaluation.
*/
-
- if ((invoker->nline <= word) || (invoker->line[word] < 0)) {
+
+ int pc = 0;
+ CmdFrame *ctxPtr = (CmdFrame *)
+ TclStackAlloc(interp, sizeof(CmdFrame));
+
+ *ctxPtr = *invoker;
+ if (invoker->type == TCL_LOCATION_BC) {
/*
- * Dynamic script, or dynamic context, force our own
- * context.
+ * Note: Type BC => ctxPtr->data.eval.path is not used.
+ * ctxPtr->data.tebc.codePtr is used instead.
*/
-
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
- result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
-
- } else {
+
+ TclGetSrcInfoForPc(ctxPtr);
+ pc = 1;
+ }
+
+ if (ctxPtr->type == TCL_LOCATION_SOURCE) {
/*
- * Try to get an absolute context for the evaluation.
+ * Absolute context to reuse.
*/
-
- int pc = 0;
- CmdFrame *ctxPtr = (CmdFrame *)
- TclStackAlloc(interp, sizeof(CmdFrame));
-
- *ctxPtr = *invoker;
- if (invoker->type == TCL_LOCATION_BC) {
- /*
- * Note: Type BC => ctxPtr->data.eval.path is not used.
- * ctxPtr->data.tebc.codePtr is used instead.
- */
-
- TclGetSrcInfoForPc(ctxPtr);
- pc = 1;
- }
-
- if (ctxPtr->type == TCL_LOCATION_SOURCE) {
- /*
- * Absolute context to reuse.
- */
-
- iPtr->invokeCmdFramePtr = ctxPtr;
- iPtr->evalFlags |= TCL_EVAL_CTX;
-
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
- result = TclEvalEx(interp, script, numSrcBytes, flags,
- ctxPtr->line[word]);
-
- if (pc) {
- /*
- * Death of SrcInfo reference.
- */
-
- Tcl_DecrRefCount(ctxPtr->data.eval.path);
- }
- } else {
+
+ iPtr->invokeCmdFramePtr = ctxPtr;
+ iPtr->evalFlags |= TCL_EVAL_CTX;
+
+ script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ result = TclEvalEx(interp, script, numSrcBytes, flags,
+ ctxPtr->line[word]);
+
+ if (pc) {
/*
- * Dynamic context or script, easier to make our own as
- * well.
+ * Death of SrcInfo reference.
*/
-
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
- result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
+
+ Tcl_DecrRefCount(ctxPtr->data.eval.path);
}
-
- TclStackFree(interp, ctxPtr);
+ } else {
+ /*
+ * Dynamic context or script, easier to make our own as
+ * well.
+ */
+
+ script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
}
+
+ TclStackFree(interp, ctxPtr);
}
- } else {
- /*
- * Let the compiler/engine subsystem do the evaluation.
- *
- * TIP #280 The invoker provides us with the context for the script.
- * We transfer this to the byte code compiler.
- */
+ }
+ TclDecrRefCount(objPtr);
+ return result;
+}
- savedVarFramePtr = iPtr->varFramePtr;
- if (flags & TCL_EVAL_GLOBAL) {
- iPtr->varFramePtr = iPtr->rootFramePtr;
+static int
+TEOEx_ByteCodeCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *savedVarFramePtr = data[0];
+ Tcl_Obj *objPtr = data[1];
+ int allowExceptions = PTR2INT(data[2]);
+ char *script;
+ int numSrcBytes;
+
+ if (iPtr->numLevels == 0) {
+ if (result == TCL_RETURN) {
+ result = TclUpdateReturnInfo(iPtr);
}
-
- result = TclCompEvalObj(interp, objPtr, invoker, word);
-
- /*
- * If we are again at the top level, process any unusual return code
- * returned by the evaluated code.
- */
-
- if (iPtr->numLevels == 0) {
- if (result == TCL_RETURN) {
- result = TclUpdateReturnInfo(iPtr);
- }
- if ((result != TCL_OK) && (result != TCL_ERROR)
- && !allowExceptions) {
- ProcessUnexpectedResult(interp, result);
- result = TCL_ERROR;
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
- Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
- }
+ if ((result != TCL_OK) && (result != TCL_ERROR)
+ && !allowExceptions) {
+ ProcessUnexpectedResult(interp, result);
+ result = TCL_ERROR;
+ script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
}
- iPtr->evalFlags = 0;
+ }
+ iPtr->evalFlags = 0;
+
+ /* Restore the callFrame if this was a TCL_EVAL_GLOBAL */
+
+ if (savedVarFramePtr) {
iPtr->varFramePtr = savedVarFramePtr;
}
+
+ TclDecrRefCount(objPtr);
+ return result;
+}
- done:
+static int
+TEOEx_ListCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *objPtr = data[0];
+ CmdFrame *eoFramePtr = data[1];
+ Tcl_Obj *copyPtr = data[2];
+
+ /* Remove the cmdFrame if it was added */
+ Tcl_DecrRefCount(copyPtr);
+ iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
+ ckfree((char *) eoFramePtr->line);
+ eoFramePtr->line = NULL;
+ eoFramePtr->nline = 0;
+ TclStackFree(interp, eoFramePtr);
+
TclDecrRefCount(objPtr);
return result;
}
@@ -6230,8 +6618,7 @@ ExprIsqrtFunc(
return TCL_OK;
negarg:
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("square root of negative argument", -1));
+ Tcl_SetResult(interp, "square root of negative argument", TCL_STATIC);
return TCL_ERROR;
}
@@ -6991,6 +7378,347 @@ TclDTraceInfo(
#endif /* USE_DTRACE */
/*
+ *----------------------------------------------------------------------
+ *
+ * TclNR_CallObjProc --
+ *
+ * This function calls an objProc directly while managing things properly
+ * if it happens to be an NR objProc. It is meant to be used by extenders
+ * that provide an NR implementation of a command, as this function
+ * permits a trivial coding of the non-NR objProc.
+ *
+ * Results:
+ * The return value is a standard Tcl completion code such as TCL_OK or
+ * TCL_ERROR. A result or error message is left in interp's result.
+ *
+ * Side effects:
+ * Depends on the objProc.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclNR_CallObjProc(
+ Tcl_Interp *interp,
+ Tcl_ObjCmdProc *objProc,
+ ClientData clientData,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ int result = TCL_OK;
+ TEOV_record *recordPtr;
+
+ /*
+ * Push an empty record. If this is an NR call, it will modify it
+ * accordingly.
+ */
+
+ PUSH_RECORD(interp, recordPtr);
+ result = (*objProc)(clientData, interp, objc, objv);
+ return NRPostProcess(interp, result, objc, objv);
+}
+
+static int
+NRPostProcess(
+ Tcl_Interp *interp,
+ int result,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ TEOV_record *recordPtr = TOP_RECORD(interp);
+
+ if ((result == TCL_OK) && VALID_NEW_REQUEST(recordPtr)) {
+ switch(recordPtr->type) {
+ case TCL_NR_BC_TYPE: {
+ result = TclExecuteByteCode(interp, recordPtr->data.codePtr);
+ break;
+ }
+ case TCL_NR_CMD_TYPE: {
+ Tcl_Obj *objPtr = recordPtr->data.obj.objPtr;
+ int flags = recordPtr->data.obj.flags;
+ Tcl_Obj **objv;
+ int objc;
+
+ Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv);
+ result = Tcl_EvalObjv(interp, objc, objv, flags);
+ break;
+ }
+ case TCL_NR_SCRIPT_TYPE: {
+ Tcl_Obj *objPtr = recordPtr->data.obj.objPtr;
+ int flags = recordPtr->data.obj.flags;
+
+ result = TclEvalObjEx(interp, objPtr, flags, NULL, 0);
+ break;
+ }
+ case TCL_NR_OBJPROC_TYPE: {
+ Tcl_ObjCmdProc *objProc = recordPtr->data.objProc.objProc;
+ ClientData clientData = recordPtr->data.objProc.clientData;
+
+ if (!objc) {
+ Tcl_Panic("NRPostProcess: something is very wrong!");
+ }
+ result = (*objProc)(clientData, interp, objc, objv);
+ break;
+ }
+ default:
+ Tcl_Panic("NRPostProcess: invalid record type");
+ }
+ }
+
+ assert((TOP_RECORD(interp) == recordPtr));
+ return TclEvalObjv_NR2(interp, result, recordPtr->nextPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNR_CreateCommand --
+ *
+ * Define a new NRE-enabled object-based command in a command table.
+ *
+ * Results:
+ * The return value is a token for the command, which can be used in
+ * future calls to Tcl_GetCommandName.
+ *
+ * Side effects:
+ * If no command named "cmdName" already exists for interp, one is
+ * created. Otherwise, if a command does exist, then if the object-based
+ * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand
+ * was called previously for the same command and just set its
+ * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old
+ * command.
+ *
+ * In the future, during bytecode evaluation when "cmdName" is seen as
+ * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based
+ * Tcl_ObjCmdProc proc will be called. When the command is deleted from
+ * the table, deleteProc will be called. See the manual entry for details
+ * on the calling sequence.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+TclNR_CreateCommand(
+ Tcl_Interp *interp, /* Token for command interpreter (returned by
+ * previous call to Tcl_CreateInterp). */
+ const char *cmdName, /* Name of command. If it contains namespace
+ * qualifiers, the new command is put in the
+ * specified namespace; otherwise it is put in
+ * the global namespace. */
+ Tcl_ObjCmdProc *proc, /* Object-based function to associate with
+ * name, provides direct access for direct calls */
+ Tcl_ObjCmdProc *nreProc, /* Object-based function to associate with
+ * name, provides NR implementation */
+ ClientData clientData, /* Arbitrary value to pass to object
+ * function. */
+ Tcl_CmdDeleteProc *deleteProc)
+ /* If not NULL, gives a function to call when
+ * this command is deleted. */
+{
+
+ Command *cmdPtr;
+
+ cmdPtr = (Command *) Tcl_CreateObjCommand(interp, cmdName, proc, clientData,
+ deleteProc);
+ cmdPtr->nreProc = nreProc;
+ return (Tcl_Command) cmdPtr;
+}
+
+/*
+ * These are the previous contents of tclNRE.c, part of the NRE api.
+ *
+ */
+
+
+/*
+ * TclNREvalCmd should only be called as an optimisation: when objPtr is known
+ * to be a canonical list that is not (and will not!) be shared
+ */
+
+int
+TclNREvalCmd(
+ Tcl_Interp * interp,
+ Tcl_Obj * objPtr,
+ int flags)
+{
+ TEOV_record *recordPtr = TOP_RECORD(interp);
+
+ Tcl_IncrRefCount(objPtr);
+ recordPtr->type = TCL_NR_CMD_TYPE;
+ recordPtr->data.obj.objPtr = objPtr;
+ recordPtr->data.obj.flags = flags;
+ return TCL_OK;
+}
+
+/*****************************************************************************
+ * Stuff for the public api
+ *****************************************************************************/
+
+int
+TclNR_EvalObjv(
+ Tcl_Interp *interp, /* Interpreter in which to evaluate the
+ * command. Also used for error reporting. */
+ int objc, /* Number of words in command. */
+ Tcl_Obj *const objv[], /* An array of pointers to objects that are
+ * the words that make up the command. */
+ int flags) /* Collection of OR-ed bits that control the
+ * evaluation of the script. Only
+ * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
+ * TCL_EVAL_NOERR are currently supported. */
+{
+ Tcl_Obj *listPtr = Tcl_NewListObj(objc, objv);
+
+ return TclNREvalCmd(interp, listPtr, flags);
+}
+
+int
+TclNR_EvalObj(
+ Tcl_Interp * interp,
+ Tcl_Obj * objPtr,
+ int flags)
+{
+ TEOV_record *recordPtr = TOP_RECORD(interp);
+ List *listRep = objPtr->internalRep.twoPtrValue.ptr1;
+
+ Tcl_IncrRefCount(objPtr);
+ if ((objPtr->typePtr == &tclListType)
+ && (!objPtr->bytes || listRep->canonicalFlag)) {
+ /*
+ * Shimmer protection! Always pass an unshared obj. The caller could
+ * incr the refCount of objPtr AFTER calling us! To be completely safe
+ * we always make a copy.
+ */
+
+ Tcl_Obj *origPtr = objPtr;
+
+ objPtr = TclListObjCopy(NULL, origPtr);
+ Tcl_IncrRefCount(objPtr);
+ TclDecrRefCount(origPtr);
+
+ recordPtr->type = TCL_NR_CMD_TYPE;
+ } else {
+ recordPtr->type = TCL_NR_SCRIPT_TYPE;
+ }
+ recordPtr->data.obj.objPtr = objPtr;
+ recordPtr->data.obj.flags = flags;
+ return TCL_OK;
+}
+
+int
+TclNR_ObjProc(
+ Tcl_Interp * interp,
+ Tcl_ObjCmdProc *objProc,
+ ClientData clientData)
+{
+ TEOV_record *recordPtr = TOP_RECORD(interp);
+
+ recordPtr->type = TCL_NR_OBJPROC_TYPE;
+ recordPtr->data.objProc.objProc = objProc;
+ recordPtr->data.objProc.clientData = clientData;
+ return TCL_OK;
+}
+
+/*****************************************************************************
+ * Stuff for tailcalls
+ *****************************************************************************/
+
+/*
+ * Just to show that IT CAN BE DONE! The precise semantics are not simple,
+ * require more thought. Possibly need a new Tcl return code to do it right?
+ * Questions include:
+ * (1) How is the objc/objv tailcall to be run? My current thinking is that
+ * it should essentially be
+ * [tailcall a b c] <=> [uplevel 1 [list a b c]]
+ * with two caveats
+ * (a) the current frame is dropped first, after running all
+ * pending cleanup tasks and saving its namespace
+ * (b) 'a' is looked up in the returning frame's namespace, but the
+ * command is run in the context to which we are returning
+ * Current implementation does this if [tailcall] is called from within
+ * a proc, panics otherwise-
+ * (2) Should a tailcall bypass [catch] in the returning frame? Current
+ * implementation does not - it causes an error.
+ *
+ * FIXME!
+ */
+
+int
+TclTailcallObjCmd(
+ ClientData clientData,
+ Tcl_Interp * interp,
+ int objc,
+ Tcl_Obj *const objv[] )
+{
+ Interp *iPtr = (Interp *) interp;
+ TEOV_record *recordPtr = TOP_RECORD(interp);
+ Tcl_Obj *listPtr;
+
+ /*
+ * Do NOT allow tailcall to be called from a non-proc/lambda: tough to
+ * manage the proper semantics, especially for [uplevel $x tailcall foo]
+ */
+
+ if (!iPtr->varFramePtr->isProcCallFrame) {
+ Tcl_SetResult(interp, "tailcall can only be called from a proc or lambda", TCL_STATIC);
+ return TCL_ERROR;
+ }
+
+ listPtr = Tcl_NewListObj(objc-1, objv+1);
+ TclNR_EvalObj(interp, listPtr, 0);
+ recordPtr->type = TCL_NR_TAILCALL_TYPE;
+ return TCL_OK;
+}
+
+void TclNR_AddCallback(
+ Tcl_Interp *interp,
+ TclNR_PostProc *postProcPtr,
+ ClientData data0,
+ ClientData data1,
+ ClientData data2,
+ ClientData data3)
+{
+ TEOV_record *recordPtr;
+ TEOV_callback *callbackPtr;
+
+ if (!postProcPtr) {
+ Tcl_Panic("Adding a callback without and objProc?!");
+ }
+
+ recordPtr = TOP_RECORD(interp);
+ TclSmallAlloc(sizeof(TEOV_callback), callbackPtr);
+
+ callbackPtr->procPtr = postProcPtr;
+ callbackPtr->data0 = data0;
+ callbackPtr->data1 = data1;
+ callbackPtr->data2 = data2;
+ callbackPtr->data3 = data3;
+
+ callbackPtr->nextPtr = recordPtr->callbackPtr;
+ recordPtr->callbackPtr = callbackPtr;
+}
+
+TEOV_record *
+TclNRPushRecord(
+ Tcl_Interp *interp)
+{
+ TEOV_record *recordPtr;
+
+ PUSH_RECORD(interp, recordPtr);
+ return recordPtr;
+}
+
+void
+TclNRPopAndFreeRecord (
+ Tcl_Interp * interp)
+{
+ TEOV_record *recordPtr;
+
+ POP_RECORD(interp, recordPtr);
+ FREE_RECORD(interp, recordPtr);
+}
+
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index d6127b0..1b90331 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdAH.c,v 1.95 2008/05/30 22:54:27 dkf Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.96 2008/07/13 09:03:33 msofer Exp $
*/
#include "tclInt.h"
@@ -660,8 +660,7 @@ Tcl_EvalObjCmd(
* TIP #280. Make invoking context available to eval'd script.
*/
- result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT,
- iPtr->cmdFramePtr, 1);
+ result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT, iPtr->cmdFramePtr, 1);
} else {
/*
* More than one argument: concatenate them together with spaces
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 7e6ff50..21ff9cc 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.h,v 1.92 2008/06/08 03:21:33 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.93 2008/07/13 09:03:33 msofer Exp $
*/
#ifndef _TCLCOMPILATION
@@ -840,7 +840,7 @@ MODULE_SCOPE int TclEvalObjvInternal(Tcl_Interp *interp,
*----------------------------------------------------------------
*/
-MODULE_SCOPE int TclCompEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
const CmdFrame *invoker, int word);
/*
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index a09429a..5198401 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDecls.h,v 1.134 2008/06/13 05:45:09 mistachkin Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.135 2008/07/13 09:03:33 msofer Exp $
*/
#ifndef _TCLDECLS
@@ -3513,6 +3513,50 @@ EXTERN int Tcl_CancelEval (Tcl_Interp * interp,
/* 581 */
EXTERN int Tcl_Canceled (Tcl_Interp * interp, int flags);
#endif
+#ifndef TclNR_CreateCommand_TCL_DECLARED
+#define TclNR_CreateCommand_TCL_DECLARED
+/* 582 */
+EXTERN Tcl_Command TclNR_CreateCommand (Tcl_Interp * interp,
+ CONST char * cmdName, Tcl_ObjCmdProc * proc,
+ Tcl_ObjCmdProc * nreProc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc * deleteProc);
+#endif
+#ifndef TclNR_EvalObj_TCL_DECLARED
+#define TclNR_EvalObj_TCL_DECLARED
+/* 583 */
+EXTERN int TclNR_EvalObj (Tcl_Interp * interp, Tcl_Obj * objPtr,
+ int flags);
+#endif
+#ifndef TclNR_EvalObjv_TCL_DECLARED
+#define TclNR_EvalObjv_TCL_DECLARED
+/* 584 */
+EXTERN int TclNR_EvalObjv (Tcl_Interp * interp, int objc,
+ Tcl_Obj *CONST objv[], int flags);
+#endif
+#ifndef TclNR_ObjProc_TCL_DECLARED
+#define TclNR_ObjProc_TCL_DECLARED
+/* 585 */
+EXTERN int TclNR_ObjProc (Tcl_Interp * interp,
+ Tcl_ObjCmdProc * objProc,
+ ClientData clientData);
+#endif
+#ifndef TclNR_AddCallback_TCL_DECLARED
+#define TclNR_AddCallback_TCL_DECLARED
+/* 586 */
+EXTERN void TclNR_AddCallback (Tcl_Interp * interp,
+ TclNR_PostProc * postProcPtr,
+ ClientData data0, ClientData data1,
+ ClientData data2, ClientData data3);
+#endif
+#ifndef TclNR_CallObjProc_TCL_DECLARED
+#define TclNR_CallObjProc_TCL_DECLARED
+/* 587 */
+EXTERN int TclNR_CallObjProc (Tcl_Interp * interp,
+ Tcl_ObjCmdProc * objProc,
+ ClientData clientData, int objc,
+ Tcl_Obj *const objv[]);
+#endif
typedef struct TclStubHooks {
CONST struct TclPlatStubs *tclPlatStubs;
@@ -4154,6 +4198,12 @@ typedef struct TclStubs {
void (*tcl_AppendPrintfToObj) (Tcl_Obj * objPtr, CONST char * format, ...); /* 579 */
int (*tcl_CancelEval) (Tcl_Interp * interp, Tcl_Obj * resultObjPtr, ClientData clientData, int flags); /* 580 */
int (*tcl_Canceled) (Tcl_Interp * interp, int flags); /* 581 */
+ Tcl_Command (*tclNR_CreateCommand) (Tcl_Interp * interp, CONST char * cmdName, Tcl_ObjCmdProc * proc, Tcl_ObjCmdProc * nreProc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc); /* 582 */
+ int (*tclNR_EvalObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags); /* 583 */
+ int (*tclNR_EvalObjv) (Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags); /* 584 */
+ int (*tclNR_ObjProc) (Tcl_Interp * interp, Tcl_ObjCmdProc * objProc, ClientData clientData); /* 585 */
+ void (*tclNR_AddCallback) (Tcl_Interp * interp, TclNR_PostProc * postProcPtr, ClientData data0, ClientData data1, ClientData data2, ClientData data3); /* 586 */
+ int (*tclNR_CallObjProc) (Tcl_Interp * interp, Tcl_ObjCmdProc * objProc, ClientData clientData, int objc, Tcl_Obj *const objv[]); /* 587 */
} TclStubs;
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
@@ -6554,6 +6604,30 @@ extern CONST TclStubs *tclStubsPtr;
#define Tcl_Canceled \
(tclStubsPtr->tcl_Canceled) /* 581 */
#endif
+#ifndef TclNR_CreateCommand
+#define TclNR_CreateCommand \
+ (tclStubsPtr->tclNR_CreateCommand) /* 582 */
+#endif
+#ifndef TclNR_EvalObj
+#define TclNR_EvalObj \
+ (tclStubsPtr->tclNR_EvalObj) /* 583 */
+#endif
+#ifndef TclNR_EvalObjv
+#define TclNR_EvalObjv \
+ (tclStubsPtr->tclNR_EvalObjv) /* 584 */
+#endif
+#ifndef TclNR_ObjProc
+#define TclNR_ObjProc \
+ (tclStubsPtr->tclNR_ObjProc) /* 585 */
+#endif
+#ifndef TclNR_AddCallback
+#define TclNR_AddCallback \
+ (tclStubsPtr->tclNR_AddCallback) /* 586 */
+#endif
+#ifndef TclNR_CallObjProc
+#define TclNR_CallObjProc \
+ (tclStubsPtr->tclNR_CallObjProc) /* 587 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 5587b48..690d190 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -6,7 +6,7 @@
* Copyright (c) 1996-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 by Scriptics Corporation.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2002-2005 by Miguel Sofer.
+ * Copyright (c) 2002-2008 by Miguel Sofer.
* Copyright (c) 2005-2007 by Donal K. Fellows.
* Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
* Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
@@ -14,16 +14,20 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.375 2008/06/30 01:10:46 das Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.376 2008/07/13 09:03:33 msofer Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
#include "tommath.h"
+#include "tclNRE.h"
#include <math.h>
#include <float.h>
+static TclNR_PostProc TailcallFromTebc;
+
+
/*
* Hack to determine whether we may expect IEEE floating point. The hack is
* formally incorrect in that non-IEEE platforms might have the same precision
@@ -163,6 +167,58 @@ static BuiltinFunc tclBuiltinFuncTable[] = {
#endif
/*
+ * NR_TEBC
+ * Helpers for NR - non-recursive calls to TEBC
+ */
+
+typedef struct BottomData {
+#if USE_NR_TEBC
+ struct BottomData *prevBottomPtr;
+ TEOV_record *recordPtr; /* Top record on TEOVI's cleanup stack when
+ * this level was entered. */
+ ByteCode *codePtr; /* The following data is used on return */
+ unsigned char *pc; /* TO this level: they record the state when */
+ ptrdiff_t *catchTop; /* a new codePtr was received for NR */
+ int cleanup; /* execution. */
+ Tcl_Obj *auxObjList;
+#endif
+} BottomData;
+
+#if USE_NR_TEBC
+
+#define NR_DATA_INIT() \
+ bottomPtr->prevBottomPtr = oldBottomPtr; \
+ bottomPtr->recordPtr = TOP_RECORD(iPtr); \
+ bottomPtr->codePtr = codePtr
+
+#define NR_DATA_BURY() \
+ bottomPtr->pc = pc; \
+ bottomPtr->catchTop = catchTop; \
+ bottomPtr->cleanup = cleanup; \
+ bottomPtr->auxObjList = auxObjList; \
+ oldBottomPtr = bottomPtr
+
+#define NR_DATA_DIG() \
+ pc = bottomPtr->pc; \
+ codePtr = bottomPtr->codePtr; \
+ catchTop = bottomPtr->catchTop; \
+ cleanup = bottomPtr->cleanup; \
+ auxObjList = bottomPtr->auxObjList; \
+ iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr
+#endif
+
+#define PUSH_AUX_OBJ(objPtr) \
+ objPtr->internalRep.twoPtrValue.ptr2 = auxObjList; \
+ auxObjList = objPtr
+
+#define POP_AUX_OBJ() \
+ { \
+ Tcl_Obj *tmpPtr = auxObjList; \
+ auxObjList = (Tcl_Obj *) tmpPtr->internalRep.twoPtrValue.ptr2; \
+ Tcl_DecrRefCount(tmpPtr); \
+ }
+
+/*
* These variable-access macros have to coincide with those in tclVar.c
*/
@@ -746,6 +802,8 @@ TclCreateExecEnv(
Tcl_IncrRefCount(eePtr->constants[0]);
TclNewBooleanObj(eePtr->constants[1], 1);
Tcl_IncrRefCount(eePtr->constants[1]);
+ eePtr->recordPtr = NULL;
+ eePtr->tebcCall = 0;
esPtr->prevPtr = NULL;
esPtr->nextPtr = NULL;
@@ -820,6 +878,9 @@ TclDeleteExecEnv(
TclDecrRefCount(eePtr->constants[0]);
TclDecrRefCount(eePtr->constants[1]);
+ if (eePtr->recordPtr) {
+ Tcl_Panic("Deleting execEnv with pending TEOV callbacks!");
+ }
ckfree((char *) eePtr);
}
@@ -1079,6 +1140,25 @@ StackReallocWords(
}
void
+TclStackPurge(
+ Tcl_Interp *interp,
+ Tcl_Obj **tosPtr)
+{
+ Tcl_Obj **newTosPtr = GET_TOSPTR(interp);
+
+ if (!tosPtr) {
+ Tcl_Panic("TclStackPurge: cannot purge to NULL");
+ }
+ while (newTosPtr && (newTosPtr != tosPtr)) {
+ TclStackFree(interp, NULL);
+ newTosPtr = GET_TOSPTR(interp);
+ }
+ if (newTosPtr != tosPtr) {
+ Tcl_Panic("TclStackPurge: requested tosPtr not here");
+ }
+}
+
+void
TclStackFree(
Tcl_Interp *interp,
void *freePtr)
@@ -1103,7 +1183,7 @@ TclStackFree(
esPtr = eePtr->execStackPtr;
markerPtr = esPtr->markerPtr;
- if (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr) {
+ if ((freePtr != NULL) && (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr)) {
Tcl_Panic("TclStackFree: incorrect freePtr. Call out of sequence?");
}
@@ -1195,14 +1275,11 @@ TclStackRealloc(
*--------------------------------------------------------------
*/
-int
-Tcl_ExprObj(
- Tcl_Interp *interp, /* Context in which to evaluate the
- * expression. */
- register Tcl_Obj *objPtr, /* Points to Tcl object containing expression
- * to evaluate. */
- Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression
- * result is stored if no errors occur. */
+
+static ByteCode *
+CompileExprObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr)
{
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
@@ -1210,14 +1287,6 @@ Tcl_ExprObj(
register ByteCode *codePtr = NULL;
/* Tcl Internal type of bytecode. Initialized
* to avoid compiler warning. */
- int result;
-
- /*
- * Execute the expression after first saving the interpreter's result.
- */
-
- Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp);
- Tcl_IncrRefCount(saveObjPtr);
/*
* Get the expression ByteCode from the object. If it exists, make sure it
@@ -1274,6 +1343,31 @@ Tcl_ExprObj(
}
#endif /* TCL_COMPILE_DEBUG */
}
+ return codePtr;
+}
+
+int
+Tcl_ExprObj(
+ Tcl_Interp *interp, /* Context in which to evaluate the
+ * expression. */
+ register Tcl_Obj *objPtr, /* Points to Tcl object containing expression
+ * to evaluate. */
+ Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression
+ * result is stored if no errors occur. */
+{
+ Interp *iPtr = (Interp *) interp;
+ int result;
+ ByteCode *codePtr;
+
+ /*
+ * Execute the expression after first saving the interpreter's result.
+ */
+
+ Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(saveObjPtr);
+
+ codePtr = CompileExprObj(interp, objPtr);
+
Tcl_ResetResult(interp);
@@ -1377,24 +1471,21 @@ FreeExprCodeInternalRep(
/*
*----------------------------------------------------------------------
*
- * TclCompEvalObj --
+ * TclCompileObj --
*
- * This procedure evaluates the script contained in a Tcl_Obj by first
- * compiling it and then passing it to TclExecuteByteCode.
+ * This procedure compiles the script contained in a Tcl_Obj
*
* Results:
- * The return value is one of the return codes defined in tcl.h (such as
- * TCL_OK), and interp->objResultPtr refers to a Tcl object that either
- * contains the result of executing the code or an error message.
+ * A pointer to the corresponding ByteCode
*
* Side effects:
- * Almost certainly, depending on the ByteCode's instructions.
+ * The object is shimmered to bytecode type
*
*----------------------------------------------------------------------
*/
-int
-TclCompEvalObj(
+ByteCode *
+TclCompileObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
const CmdFrame *invoker,
@@ -1402,7 +1493,6 @@ TclCompEvalObj(
{
register Interp *iPtr = (Interp *) interp;
register ByteCode *codePtr; /* Tcl Internal type of bytecode. */
- int result;
Namespace *namespacePtr;
/*
@@ -1414,15 +1504,12 @@ TclCompEvalObj(
TclResetCancellation(interp, 0);
- iPtr->numLevels++;
if (TclInterpReady(interp) == TCL_ERROR) {
- result = TCL_ERROR;
- goto done;
+ return NULL;
}
if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
- result = TCL_ERROR;
- goto done;
+ return NULL;
}
namespacePtr = iPtr->varFramePtr->nsPtr;
@@ -1488,13 +1575,7 @@ TclCompEvalObj(
*/
runCompiledObj:
- codePtr->refCount++;
- result = TclExecuteByteCode(interp, codePtr);
- codePtr->refCount--;
- if (codePtr->refCount <= 0) {
- TclCleanupByteCode(codePtr);
- }
- goto done;
+ return codePtr;
}
recompileObj:
@@ -1516,11 +1597,7 @@ TclCompEvalObj(
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
}
- goto runCompiledObj;
-
- done:
- iPtr->numLevels--;
- return result;
+ goto runCompiledObj;
}
/*
@@ -1687,6 +1764,23 @@ TclExecuteByteCode(
#define WriteTraced(varPtr) ((varPtr)->flags & VAR_TRACED_WRITE)
/*
+ * Bottom of allocated stack holds the NR data
+ */
+
+ int initLevel;
+
+ /* NR_TEBC */
+
+ BottomData *bottomPtr;
+#if USE_NR_TEBC
+ BottomData *oldBottomPtr = NULL;
+
+ /* for tailcall support */
+ Namespace *lookupNsPtr = NULL;
+ Tcl_Obj *tailObjPtr = NULL;
+#endif
+
+ /*
* Constants: variables that do not change during the execution, used
* sporadically.
*/
@@ -1706,11 +1800,11 @@ TclExecuteByteCode(
ptrdiff_t *catchTop;
register Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
* stack. */
- register unsigned char *pc = codePtr->codeStart;
- /* The current program counter. */
+ register unsigned char *pc; /* The current program counter. */
int instructionCount = 0; /* Counter that is used to work out when to
* call Tcl_AsyncReady() */
- Tcl_Obj *expandNestList = NULL;
+ Tcl_Obj *auxObjList; /* Linked list of aux data, used for {*} and
+ * for same-level NR calls. */
int checkInterp = 0; /* Indicates when a check of interp readyness
* is necessary. Set by CACHE_STACK_INFO() */
@@ -1739,11 +1833,11 @@ TclExecuteByteCode(
int traceInstructions = (tclTraceExec == 3);
char cmdNameBuf[21];
#endif
- char *curInstName = NULL;
-
+ char *curInstName;
+
/*
- * The execution uses a unified stack: first the catch stack, immediately
- * above it a CmdFrame, then the execution stack.
+ * The execution uses a unified stack: first a BottomData, immediately
+ * above it a CmdFrame, then the catch stack, then the execution stack.
*
* Make sure the catch stack is large enough to hold the maximum number of
* catch commands that could ever be executing at the same time (this will
@@ -1751,30 +1845,115 @@ TclExecuteByteCode(
* execution stack is large enough to execute this ByteCode.
*/
- catchTop = initCatchTop = (ptrdiff_t *) (
- GrowEvaluationStack(iPtr->execEnvPtr,
- codePtr->maxExceptDepth + sizeof(CmdFrame) +
- codePtr->maxStackDepth, 0) - 1);
- bcFramePtr = (CmdFrame *) (initCatchTop + codePtr->maxExceptDepth + 1);
- tosPtr = initTosPtr = ((Tcl_Obj **) (bcFramePtr + 1)) - 1;
- esPtr = iPtr->execEnvPtr->execStackPtr;
-
/*
- * TIP #280: Initialize the frame. Do not push it yet.
+ * NR_TEBC
*/
+
+#if USE_NR_TEBC
+ nonRecursiveCallStart:
+#endif
+ codePtr->refCount++;
+ bottomPtr = (BottomData *) GrowEvaluationStack(iPtr->execEnvPtr,
+ sizeof(BottomData) + codePtr->maxExceptDepth + sizeof(CmdFrame)
+ + codePtr->maxStackDepth, 0);
+ curInstName = NULL;
+ auxObjList = NULL;
+ initLevel = 1;
+
+#if USE_NR_TEBC
+ NR_DATA_INIT(); /* record this level's data */
+
+ nonRecursiveCallReturn:
+#endif
+ bcFramePtr = (CmdFrame *) (bottomPtr + 1);
+ initCatchTop = ((ptrdiff_t *) (bcFramePtr + 1)) - 1;
+ initTosPtr = (Tcl_Obj **) (initCatchTop + codePtr->maxExceptDepth);
+ esPtr = iPtr->execEnvPtr->execStackPtr;
- bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
- ? TCL_LOCATION_PREBC : TCL_LOCATION_BC);
- bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1);
- bcFramePtr->framePtr = iPtr->framePtr;
- bcFramePtr->nextPtr = iPtr->cmdFramePtr;
- bcFramePtr->nline = 0;
- bcFramePtr->line = NULL;
+ namespacePtr = iPtr->varFramePtr->nsPtr;
+ compiledLocals = iPtr->varFramePtr->compiledLocals;
- bcFramePtr->data.tebc.codePtr = codePtr;
- bcFramePtr->data.tebc.pc = NULL;
- bcFramePtr->cmd.str.cmd = NULL;
- bcFramePtr->cmd.str.len = 0;
+ if (initLevel) {
+ initLevel = 0;
+ pc = codePtr->codeStart;
+ catchTop = initCatchTop;
+ tosPtr = initTosPtr;
+
+ /*
+ * TIP #280: Initialize the frame. Do not push it yet.
+ */
+
+ bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
+ ? TCL_LOCATION_PREBC : TCL_LOCATION_BC);
+ bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1);
+ bcFramePtr->framePtr = iPtr->framePtr;
+ bcFramePtr->nextPtr = iPtr->cmdFramePtr;
+ bcFramePtr->nline = 0;
+ bcFramePtr->line = NULL;
+
+ bcFramePtr->data.tebc.codePtr = codePtr;
+ bcFramePtr->data.tebc.pc = NULL;
+ bcFramePtr->cmd.str.cmd = NULL;
+ bcFramePtr->cmd.str.len = 0;
+#if USE_NR_TEBC
+ } else if (tailObjPtr) {
+ /*
+ * A request to perform a tailcall; a frame has already been dropped,
+ * so we just have to ...
+ * (Note that we already have a refcount for tailObjPtr!)
+ */
+
+ *++tosPtr = tailObjPtr;
+ tailObjPtr = NULL;
+ iPtr->lookupNsPtr = lookupNsPtr;
+ lookupNsPtr = NULL;
+
+ /*
+ * Fake pc, INST_EVAL STK will fix this and resume properly
+ */
+ pc--;
+ goto tailCallEntryPoint;
+#endif
+ } else {
+ /*
+ * Returning from a non-recursive call. State is already completely
+ * reset, now process the return.
+ */
+
+ if (result == TCL_OK) {
+ /*
+ * Reset the interp's result to avoid possible duplications of
+ * large objects [Bug 781585]. We do not call Tcl_ResetResult
+ * to avoid any side effects caused by the resetting of
+ * errorInfo and errorCode [Bug 804681], which are not needed
+ * here. We chose instead to manipulate the interp's object
+ * result directly.
+ *
+ * Note that the result object is now in objResultPtr, it
+ * keeps the refCount it had in its role of
+ * iPtr->objResultPtr.
+ */
+
+#ifndef TCL_COMPILE_DEBUG
+ if (*pc == INST_POP) {
+ pc++;
+ } else {
+#endif
+ objResultPtr = Tcl_GetObjResult(interp);
+ *(++tosPtr) = objResultPtr;
+
+ TclNewObj(objResultPtr);
+ Tcl_IncrRefCount(objResultPtr);
+ iPtr->objResultPtr = objResultPtr;
+#ifndef TCL_COMPILE_DEBUG
+ }
+#endif
+ } else {
+ cleanup = 0; /* already cleaned up */
+ pc--; /* was pointing to next instruction */
+ goto processExceptionReturn;
+ }
+ }
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
@@ -1788,9 +1967,6 @@ TclExecuteByteCode(
iPtr->stats.numExecutions++;
#endif
- namespacePtr = iPtr->varFramePtr->nsPtr;
- compiledLocals = iPtr->varFramePtr->compiledLocals;
-
/*
* Loop executing instructions until a "done" instruction, a TCL_RETURN,
* or some error.
@@ -1866,7 +2042,7 @@ TclExecuteByteCode(
*/
ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, 0,
- /*checkStack*/ expandNestList == NULL);
+ /*checkStack*/ auxObjList == NULL);
if (traceInstructions) {
fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH);
TclPrintInstruction(codePtr, pc);
@@ -1920,7 +2096,7 @@ TclExecuteByteCode(
}
}
- TCL_DTRACE_INST_NEXT();
+ TCL_DTRACE_INST_NEXT();
/*
* These two instructions account for 26% of all instructions (according
@@ -2251,7 +2427,7 @@ TclExecuteByteCode(
case INST_EXPAND_START: {
/*
- * Push an element to the expandNestList. This records the current
+ * Push an element to the auxObjList. This records the current
* stack depth - i.e., the point in the stack where the expanded
* command starts.
*
@@ -2267,8 +2443,7 @@ TclExecuteByteCode(
TclNewObj(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = (void *) CURR_DEPTH;
- objPtr->internalRep.twoPtrValue.ptr2 = (void *) expandNestList;
- expandNestList = objPtr;
+ PUSH_AUX_OBJ(objPtr);
NEXT_INST_F(1, 0, 0);
}
@@ -2301,14 +2476,15 @@ TclExecuteByteCode(
length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1));
DECACHE_STACK_INFO();
- moved = (GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - 1)
- - (Tcl_Obj **) initCatchTop;
+ moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1)
+ - (Tcl_Obj **) bottomPtr;
if (moved) {
/*
* Change the global data to point to the new stack.
*/
+ bottomPtr = (BottomData *) (((Tcl_Obj **)bottomPtr) + moved);
initCatchTop += moved;
catchTop += moved;
initTosPtr += moved;
@@ -2335,15 +2511,134 @@ TclExecuteByteCode(
*/
int objc, pcAdjustment;
+ Tcl_Obj **objv;
+
+ case INST_EXPR_STK: {
+ /*
+ * Moved here to support transforming the eval of an expression to
+ * a non-recursive TEBC call.
+ */
+
+#if (USE_NR_TEBC)
+
+ pcAdjustment = 1;
+ cleanup = 1;
+ bcFramePtr->data.tebc.pc = (char *) pc;
+ iPtr->cmdFramePtr = bcFramePtr;
+ DECACHE_STACK_INFO();
+ TEBC_DATA(iPtr) = CompileExprObj(interp, OBJ_AT_TOS);
+ CACHE_STACK_INFO();
+ goto tebc_do_exec;
+#else
+ Tcl_Obj *objPtr, *valuePtr;
+
+ objPtr = OBJ_AT_TOS;
+
+ DECACHE_STACK_INFO();
+ /*Tcl_ResetResult(interp);*/
+ result = Tcl_ExprObj(interp, objPtr, &valuePtr);
+ CACHE_STACK_INFO();
+ if (result == TCL_OK) {
+ objResultPtr = valuePtr;
+ TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
+ NEXT_INST_F(1, 1, -1); /* Already has right refct. */
+ } else {
+ TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
+ Tcl_GetObjResult(interp));
+ cleanup = 1;
+ goto checkForCatch;
+ }
+#endif
+ }
+
+
+ tailCallEntryPoint:
+ case INST_EVAL_STK: {
+ /*
+ * Moved here to support transforming the eval of objects to a
+ * simple command invocation (for canonical lists) or a
+ * non-recursive TEBC call (compiled scripts).
+ */
+
+ Tcl_Obj *objPtr = OBJ_AT_TOS;
+ ByteCode *newCodePtr;
+
+ pcAdjustment = 1;
+ cleanup = 1;
+
+ if (objPtr->typePtr == &tclListType) { /* is a list... */
+ List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1;
+
+ if (objPtr->bytes == NULL || /* ...without a string rep */
+ listRepPtr->canonicalFlag) {/* ...or that is canonical */
+ objc = listRepPtr->elemCount;
+ objv = &listRepPtr->elements;
+ goto doInvocationFromEval;
+ }
+ }
+
+ /*
+ * TIP #280: The invoking context is left NULL for a dynamically
+ * constructed command. We cannot match its lines to the outer
+ * context.
+ */
+
+ DECACHE_STACK_INFO();
+ newCodePtr = TclCompileObj(interp, objPtr, NULL, 0);
+ if (newCodePtr) {
+ /*
+ * Run the bytecode in this same TEBC instance!
+ */
+#if (USE_NR_TEBC)
+ bcFramePtr->data.tebc.pc = (char *) pc;
+ iPtr->cmdFramePtr = bcFramePtr;
+ TEBC_DATA(iPtr) = newCodePtr;
+ goto tebc_do_exec;
+#else
+ result = TclExecuteByteCode(interp, newCodePtr);
+ CACHE_STACK_INFO();
+
+ if (result == TCL_OK) {
+ /*
+ * Normal return; push the eval's object result.
+ */
+
+ objResultPtr = Tcl_GetObjResult(interp);
+ TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
+ Tcl_GetObjResult(interp));
+
+ /*
+ * Reset the interp's result to avoid possible duplications of
+ * large objects [Bug 781585]. We do not call Tcl_ResetResult to
+ * avoid any side effects caused by the resetting of errorInfo and
+ * errorCode [Bug 804681], which are not needed here. We chose
+ * instead to manipulate the interp's object result directly.
+ *
+ * Note that the result object is now in objResultPtr, it keeps
+ * the refCount it had in its role of iPtr->objResultPtr.
+ */
+
+ TclNewObj(objPtr);
+ Tcl_IncrRefCount(objPtr);
+ iPtr->objResultPtr = objPtr;
+ NEXT_INST_F(1, 1, -1);
+ }
+#endif
+ }
+
+ /*
+ * Compilation failed, error
+ */
+
+ result = TCL_ERROR;
+ goto processExceptionReturn;
+ }
case INST_INVOKE_EXPANDED:
{
- Tcl_Obj *objPtr = expandNestList;
-
- expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
objc = CURR_DEPTH
- - (ptrdiff_t) objPtr->internalRep.twoPtrValue.ptr1;
- TclDecrRefCount(objPtr);
+ - (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1;
+ POP_AUX_OBJ();
}
if (objc) {
@@ -2369,7 +2664,9 @@ TclExecuteByteCode(
doInvocation:
{
- Tcl_Obj **objv = &OBJ_AT_DEPTH(objc-1);
+ objv = &OBJ_AT_DEPTH(objc-1);
+ cleanup = objc;
+ doInvocationFromEval:
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
@@ -2392,14 +2689,7 @@ TclExecuteByteCode(
#endif /*TCL_COMPILE_DEBUG*/
/*
- * Reset the instructionCount variable, since we're about to check
- * for async stuff anyway while processing TclEvalObjvInternal.
- */
-
- instructionCount = 1;
-
- /*
- * Finally, let TclEvalObjvInternal handle the command.
+ * Finally, let Tcl_EvalObjv handle the command.
*
* TIP #280: Record the last piece of info needed by
* 'TclGetSrcInfoForPc', and push the frame.
@@ -2407,10 +2697,62 @@ TclExecuteByteCode(
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
+
+ /*
+ * Reset the instructionCount variable, since we're about to check
+ * for async stuff anyway while processing Tcl_EvalObjv
+ */
+
+ instructionCount = 1;
+
DECACHE_STACK_INFO();
- result = TclEvalObjvInternal(interp, objc, objv,
- /* call from TEBC */(char *) -1, -1, 0);
+
+ TEBC_CALL(iPtr) = 1;
+ result = Tcl_EvalObjv(interp, objc, objv, TCL_EVAL_NOERR);
CACHE_STACK_INFO();
+#if (USE_NR_TEBC)
+ switch (TEBC_CALL(iPtr)) {
+ case TEBC_DO_EXEC: {
+ tebc_do_exec:
+ /*
+ * A request to execute a bytecode came back. We save
+ * the current state and restart at the top.
+ */
+ assert((result == TCL_OK));
+ TEBC_CALL(iPtr) = 0;
+ pc += pcAdjustment;
+ NR_DATA_BURY(); /* this level's state variables */
+ codePtr = TEBC_DATA(iPtr);
+ result = TCL_OK;
+ goto nonRecursiveCallStart;
+ }
+ case TEBC_DO_TAILCALL: {
+ /*
+ * A request to perform a tailcall: save the current
+ * namespace, drop a frame and eval the passed listObj
+ * in the previous frame while looking up the command
+ * in the current namespace. Read it again.
+ *
+ * We take over tailObjPtr's refcount!
+ */
+
+ assert((result == TCL_OK));
+ TEBC_CALL(iPtr) = 0;
+ tailObjPtr = TEBC_DATA(iPtr);
+ if (catchTop != initCatchTop) {
+ result = TCL_ERROR;
+ Tcl_SetResult(interp,"Tailcall called from within a catch environment",
+ TCL_STATIC);
+ Tcl_DecrRefCount(tailObjPtr);
+ tailObjPtr = NULL;
+ goto checkForCatch;
+ }
+ lookupNsPtr = iPtr->varFramePtr->nsPtr;
+ result = TCL_OK;
+ goto abnormalReturn; /* drop a level */
+ }
+ }
+#endif
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
if (result == TCL_OK) {
@@ -2418,7 +2760,7 @@ TclExecuteByteCode(
#ifndef TCL_COMPILE_DEBUG
if (*(pc+pcAdjustment) == INST_POP) {
- NEXT_INST_V((pcAdjustment+1), objc, 0);
+ NEXT_INST_V((pcAdjustment+1), cleanup, 0);
}
#endif
/*
@@ -2447,9 +2789,8 @@ TclExecuteByteCode(
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
iPtr->objResultPtr = objPtr;
- NEXT_INST_V(pcAdjustment, objc, -1);
+ NEXT_INST_V(pcAdjustment, cleanup, -1);
} else {
- cleanup = objc;
goto processExceptionReturn;
}
}
@@ -2548,74 +2889,6 @@ TclExecuteByteCode(
#endif
}
- case INST_EVAL_STK: {
- /*
- * Note to maintainers: it is important that INST_EVAL_STK pop its
- * argument from the stack before jumping to checkForCatch! DO NOT
- * OPTIMISE!
- */
-
- Tcl_Obj *objPtr = OBJ_AT_TOS;
-
- DECACHE_STACK_INFO();
-
- /*
- * TIP #280: The invoking context is left NULL for a dynamically
- * constructed command. We cannot match its lines to the outer
- * context.
- */
-
- result = TclCompEvalObj(interp, objPtr, NULL, 0);
- CACHE_STACK_INFO();
- if (result == TCL_OK) {
- /*
- * Normal return; push the eval's object result.
- */
-
- objResultPtr = Tcl_GetObjResult(interp);
- TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
- Tcl_GetObjResult(interp));
-
- /*
- * Reset the interp's result to avoid possible duplications of
- * large objects [Bug 781585]. We do not call Tcl_ResetResult to
- * avoid any side effects caused by the resetting of errorInfo and
- * errorCode [Bug 804681], which are not needed here. We chose
- * instead to manipulate the interp's object result directly.
- *
- * Note that the result object is now in objResultPtr, it keeps
- * the refCount it had in its role of iPtr->objResultPtr.
- */
-
- TclNewObj(objPtr);
- Tcl_IncrRefCount(objPtr);
- iPtr->objResultPtr = objPtr;
- NEXT_INST_F(1, 1, -1);
- } else {
- cleanup = 1;
- goto processExceptionReturn;
- }
- }
-
- case INST_EXPR_STK: {
- Tcl_Obj *objPtr, *valuePtr;
-
- objPtr = OBJ_AT_TOS;
- DECACHE_STACK_INFO();
- /*Tcl_ResetResult(interp);*/
- result = Tcl_ExprObj(interp, objPtr, &valuePtr);
- CACHE_STACK_INFO();
- if (result == TCL_OK) {
- objResultPtr = valuePtr;
- TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
- NEXT_INST_F(1, 1, -1); /* Already has right refct. */
- } else {
- TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
- Tcl_GetObjResult(interp));
- goto checkForCatch;
- }
- }
-
/*
* ---------------------------------------------------------
* Start of INST_LOAD instructions.
@@ -5043,8 +5316,7 @@ TclExecuteByteCode(
invalid = 0;
}
if (invalid) {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("negative shift argument", -1));
+ Tcl_SetResult(interp, "negative shift argument", TCL_STATIC);
result = TCL_ERROR;
goto checkForCatch;
}
@@ -5078,8 +5350,7 @@ TclExecuteByteCode(
* place to draw the line.
*/
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "integer value too large to represent", -1));
+ Tcl_SetResult(interp, "integer value too large to represent", TCL_STATIC);
result = TCL_ERROR;
goto checkForCatch;
}
@@ -5771,8 +6042,7 @@ TclExecuteByteCode(
}
}
if (type2 == TCL_NUMBER_BIG) {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("exponent too large", -1));
+ Tcl_SetResult(interp, "exponent too large", TCL_STATIC);
result = TCL_ERROR;
goto checkForCatch;
}
@@ -6207,8 +6477,7 @@ TclExecuteByteCode(
break;
case INST_EXPON:
if (big2.used > 1) {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("exponent too large", -1));
+ Tcl_SetResult(interp, "exponent too large", TCL_STATIC);
mp_clear(&big1);
mp_clear(&big2);
mp_clear(&bigResult);
@@ -7222,7 +7491,7 @@ TclExecuteByteCode(
*/
divideByZero:
- Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
+ Tcl_SetResult(interp, "divide by zero", TCL_STATIC);
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
result = TCL_ERROR;
@@ -7234,8 +7503,7 @@ TclExecuteByteCode(
*/
exponOfZero:
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "exponentiation of zero by negative power", -1));
+ Tcl_SetResult(interp, "exponentiation of zero by negative power", TCL_STATIC);
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"exponentiation of zero by negative power", NULL);
result = TCL_ERROR;
@@ -7361,13 +7629,13 @@ TclExecuteByteCode(
* INST_BEGIN_CATCH.
*/
- while ((expandNestList != NULL) && ((catchTop == initCatchTop) ||
- (*catchTop <=
- (ptrdiff_t) expandNestList->internalRep.twoPtrValue.ptr1))) {
- Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2;
-
- TclDecrRefCount(expandNestList);
- expandNestList = objPtr;
+ while (auxObjList) {
+ if ((catchTop != initCatchTop) &&
+ (*catchTop >
+ (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1)) {
+ break;
+ }
+ POP_AUX_OBJ();
}
/*
@@ -7417,7 +7685,7 @@ TclExecuteByteCode(
/*
* This is only possible when compiling a [catch] that sends its
* script to INST_EVAL. Cannot correct the compiler without
- * breakingcompat with previous .tbc compiled scripts.
+ * breaking compat with previous .tbc compiled scripts.
*/
#ifdef TCL_COMPILE_DEBUG
@@ -7465,22 +7733,22 @@ TclExecuteByteCode(
abnormalReturn:
TCL_DTRACE_INST_LAST();
+ /*
+ * Clear all expansions and same-level NR calls.
+ *
+ * Note that expansion markers have a NULL type; avoid removing other
+ * markers.
+ */
+
+ while (auxObjList) {
+ POP_AUX_OBJ();
+ }
while (tosPtr > initTosPtr) {
Tcl_Obj *objPtr = POP_OBJECT();
Tcl_DecrRefCount(objPtr);
}
- /*
- * Clear all expansions.
- */
-
- while (expandNestList) {
- Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2;
-
- TclDecrRefCount(expandNestList);
- expandNestList = objPtr;
- }
if (tosPtr < initTosPtr) {
fprintf(stderr,
"\nTclExecuteByteCode: abnormal return at pc %u: "
@@ -7491,14 +7759,104 @@ TclExecuteByteCode(
}
}
+#if USE_NR_TEBC
+ oldBottomPtr = bottomPtr->prevBottomPtr;
+#endif
+ TclStackFree(interp, bottomPtr); /* free my stack */
+
+ if (--codePtr->refCount <= 0) {
+ TclCleanupByteCode(codePtr);
+ }
+
+#if USE_NR_TEBC
+ if (oldBottomPtr) {
+ /*
+ * Restore the state to what it was previous to this bytecode.
+ *
+ * NR_TEBC
+ */
+
+ bottomPtr = oldBottomPtr; /* back to old bc */
+
+ /* Please free anything that might still be on my new stack */
+ result = TclEvalObjv_NR2(interp, result, bottomPtr->recordPtr);
+ assert((TOP_RECORD(iPtr) == bottomPtr->recordPtr));
+
+ /* restore state variables */
+ NR_DATA_DIG();
+ esPtr = iPtr->execEnvPtr->execStackPtr;
+ tosPtr = esPtr->tosPtr;
+ while (cleanup--) {
+ Tcl_Obj *objPtr = POP_OBJECT();
+ Tcl_DecrRefCount(objPtr);
+ }
+ CACHE_STACK_INFO();
+ goto nonRecursiveCallReturn;
+ }
+
+ if (tailObjPtr && result == TCL_OK) {
+ /*
+ * The best we can do here is to add the tailcall at the FRONT of the
+ * callback list. This will be a real tailcall if we're lucky to have
+ * been called from TEOV (or similar), and not-quite-but-almost if
+ * called from eg TclOO (I think).
+ * The simplest way to add to the front is:
+ * (a) push a new record
+ * (b) add the tailcall as callback to the newly-created 2nd record
+ * (c) swap the two top records: old top is still top, newly created
+ * record is second
+ */
+
+ TEOV_record *rootPtr, *recordPtr;
+
+ rootPtr = TOP_RECORD(iPtr);
+ PUSH_RECORD(iPtr, recordPtr);
+ TclNR_AddCallback(interp, TailcallFromTebc, tailObjPtr, lookupNsPtr, NULL, NULL);
+
+ /* Now swap them! */
+ recordPtr->nextPtr = rootPtr->nextPtr;
+ rootPtr->nextPtr = recordPtr;
+ TOP_RECORD(iPtr) = rootPtr;
+ }
+#endif
+ return result;
+}
+
+static int
+TailcallFromTebc(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj *tailObjPtr = data[0];
+ Namespace *lookupNsPtr = data[1];
+ int objc;
+ Tcl_Obj **objv;
+
+ Tcl_IncrRefCount(tailObjPtr); /* unshared per construction! */
+ if (result != TCL_OK) {
+ goto done;
+ }
+ result = Tcl_ListObjGetElements(NULL, tailObjPtr, &objc, &objv);
+ if (result != TCL_OK) {
+ /* shouldn't happen */
+ goto done;
+ }
+
/*
- * Restore the stack to the state it had previous to this bytecode.
+ * Note that by this time the proc's frame SHOULD BE ALREADY POPPED! We do
+ * as if it was (don't know what happens with eg TclOO), ie, assume that
+ * are already in [uplevel 1] from the proc's callFrame..
*/
- TclStackFree(interp, initCatchTop+1);
+ iPtr->lookupNsPtr = lookupNsPtr;
+ result = Tcl_EvalObjv(interp, objc, objv, TCL_EVAL_INVOKE);
+
+ done:
+ Tcl_DecrRefCount(tailObjPtr);
return result;
-#undef iPtr
}
+#undef iPtr
#ifdef TCL_COMPILE_DEBUG
/*
diff --git a/generic/tclHistory.c b/generic/tclHistory.c
index 0a01019..ea1a8ff 100644
--- a/generic/tclHistory.c
+++ b/generic/tclHistory.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclHistory.c,v 1.11 2008/04/27 22:21:30 dkf Exp $
+ * RCS: @(#) $Id: tclHistory.c,v 1.12 2008/07/13 09:03:33 msofer Exp $
*/
#include "tclInt.h"
@@ -123,7 +123,7 @@ Tcl_RecordAndEvalObj(
result = Tcl_GetCommandInfo(interp, "history", &info);
- if (result && (info.objProc == TclObjInterpProc)) {
+ if (result && (info.deleteProc == TclProcDeleteProc)) {
Proc *procPtr = (Proc *)(info.objClientData);
call = (procPtr->cmdPtr->compileProc != TclCompileNoOp);
}
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index e05298a..f5be70a 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -13,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tclInt.decls,v 1.123 2008/07/08 17:52:17 dgp Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.124 2008/07/13 09:03:33 msofer Exp $
library tcl
@@ -940,6 +940,30 @@ declare 237 generic {
int TclResetCancellation(Tcl_Interp *interp, int force)
}
+# NRE functions for "rogue" extensions to exploit NRE; they will need to
+# include NRE.h too.
+declare 238 generic {
+ int TclEvalObjv_NR2(Tcl_Interp *interp, int result,
+ struct TEOV_record *rootPtr)
+}
+declare 239 generic {
+ Tcl_ObjCmdProc TclNRInterpProc
+}
+declare 240 generic {
+ int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj,
+ int skip, ProcErrorProc errorProc)
+}
+declare 241 generic {
+ struct TEOV_record * TclNRPushRecord(Tcl_Interp *interp)
+}
+declare 242 generic {
+ void TclNRPopAndFreeRecord(Tcl_Interp *interp)
+}
+
+declare 243 generic {
+ int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags,
+ const CmdFrame *invoker, int word)
+}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 112421d..9e0f6ce 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.371 2008/06/13 05:45:12 mistachkin Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.372 2008/07/13 09:03:34 msofer Exp $
*/
#ifndef _TCLINT
@@ -1308,10 +1308,20 @@ typedef struct ExecStack {
* currently active execution stack.
*/
+struct TEOV_record;
+
typedef struct ExecEnv {
- ExecStack *execStackPtr; /* Points to the first item in the evaluation
- * stack on the heap. */
- Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" objs. */
+ ExecStack *execStackPtr; /* Points to the first item in the
+ * evaluation stack on the heap. */
+ Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1"
+ * objs. */
+ struct TEOV_record *recordPtr; /* Top record in TEOV's stack */
+ int tebcCall; /* used to distinguish tebc calls from
+ * other calls to TEOV, and other comms
+ * between TEBC and TEOV */
+ ClientData tebcData; /* used by TEOV to pass data to its
+ * calling TEBC */
+
} ExecEnv;
/*
@@ -1502,6 +1512,7 @@ typedef struct Command {
* command. */
CommandTrace *tracePtr; /* First in list of all traces set for this
* command. */
+ Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command */
} Command;
/*
@@ -1525,9 +1536,9 @@ typedef struct Command {
* (these last two flags are defined in tcl.h)
*/
-#define CMD_IS_DELETED 0x1
-#define CMD_TRACE_ACTIVE 0x2
-#define CMD_HAS_EXEC_TRACES 0x4
+#define CMD_IS_DELETED 0x1
+#define CMD_TRACE_ACTIVE 0x2
+#define CMD_HAS_EXEC_TRACES 0x4
/*
*----------------------------------------------------------------
@@ -2469,6 +2480,10 @@ MODULE_SCOPE char tclEmptyString;
*----------------------------------------------------------------
*/
+MODULE_SCOPE Tcl_ObjCmdProc TclNRNamespaceObjCmd;
+MODULE_SCOPE int TclNREvalCmd(Tcl_Interp * interp, Tcl_Obj * objPtr,
+ int flags);
+
MODULE_SCOPE void TclAdvanceLines(int *line, const char *start,
const char *end);
MODULE_SCOPE int TclArraySet(Tcl_Interp *interp,
@@ -2481,6 +2496,8 @@ MODULE_SCOPE double TclCeil(mp_int *a);
MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp,const char *value);
MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp,
Tcl_Channel chan);
+MODULE_SCOPE int TclClearRootEnsemble(ClientData data[],
+ Tcl_Interp *interp, int result);
MODULE_SCOPE void TclCleanupLiteralTable(Tcl_Interp *interp,
LiteralTable *tablePtr);
MODULE_SCOPE int TclDoubleDigits(char *buf, double value, int *signum);
@@ -2614,9 +2631,6 @@ MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string,
MODULE_SCOPE int TclParseAllWhiteSpace(const char *src, int numBytes);
MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp,
int code, int level, Tcl_Obj *returnOpts);
-#ifndef TCL_NO_STACK_CHECK
-MODULE_SCOPE int TclpGetCStackParams(int **stackBoundPtr);
-#endif
MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
MODULE_SCOPE Tcl_Obj * TclpTempFileName(void);
MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep,
@@ -3886,6 +3900,39 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum,
? 1 : 0)))
+/*
+ *----------------------------------------------------------------
+ * Allocator for small structs (<=sizeof(Tcl_Obj)) using the Tcl_Obj
+ * pool. Only checked at compile time.
+ *
+ * ONLY USE FOR CONSTANT nBytes: if you do and nBytes is too large, the
+ * compiler will error out with "duplicate case value" (thanks dkf!). If the
+ * size is dynamic, a panic will be compiled in for the wrong case.
+ *
+ * DO NOT LET THEM CROSS THREAD BOUNDARIES
+ */
+
+#define TclSmallAlloc(nbytes, memPtr) \
+ { \
+ Tcl_Obj *objPtr; \
+ switch ((nbytes)>sizeof(Tcl_Obj)) { \
+ case (2 +((nbytes)>sizeof(Tcl_Obj))): \
+ case 3: \
+ case 1: \
+ Tcl_Panic("TclSmallAlloc: nBytes too large!"); \
+ case 0: (void)0; \
+ } \
+ TclIncrObjsAllocated(); \
+ TclAllocObjStorage(objPtr); \
+ memPtr = (ClientData) objPtr; \
+ }
+
+#define TclSmallFree(memPtr) \
+ TclFreeObjStorage((Tcl_Obj *) memPtr); \
+ TclIncrObjsFreed()
+
+
+
#include "tclPort.h"
#include "tclIntDecls.h"
#include "tclIntPlatDecls.h"
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index d21bd4d..6dc36c0 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIntDecls.h,v 1.117 2008/07/08 17:52:17 dgp Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.118 2008/07/13 09:03:35 msofer Exp $
*/
#ifndef _TCLINTDECLS
@@ -1076,6 +1076,38 @@ EXTERN void TclBackgroundException (Tcl_Interp * interp,
/* 237 */
EXTERN int TclResetCancellation (Tcl_Interp * interp, int force);
#endif
+#ifndef TclEvalObjv_NR2_TCL_DECLARED
+#define TclEvalObjv_NR2_TCL_DECLARED
+/* 238 */
+EXTERN int TclEvalObjv_NR2 (Tcl_Interp * interp, int result,
+ struct TEOV_record * rootPtr);
+#endif
+/* 239 */
+EXTERN Tcl_ObjCmdProc TclNRInterpProc;
+#ifndef TclNRInterpProcCore_TCL_DECLARED
+#define TclNRInterpProcCore_TCL_DECLARED
+/* 240 */
+EXTERN int TclNRInterpProcCore (Tcl_Interp * interp,
+ Tcl_Obj * procNameObj, int skip,
+ ProcErrorProc errorProc);
+#endif
+#ifndef TclNRPushRecord_TCL_DECLARED
+#define TclNRPushRecord_TCL_DECLARED
+/* 241 */
+EXTERN struct TEOV_record * TclNRPushRecord (Tcl_Interp * interp);
+#endif
+#ifndef TclNRPopAndFreeRecord_TCL_DECLARED
+#define TclNRPopAndFreeRecord_TCL_DECLARED
+/* 242 */
+EXTERN void TclNRPopAndFreeRecord (Tcl_Interp * interp);
+#endif
+#ifndef TclNREvalObjEx_TCL_DECLARED
+#define TclNREvalObjEx_TCL_DECLARED
+/* 243 */
+EXTERN int TclNREvalObjEx (Tcl_Interp * interp,
+ Tcl_Obj * objPtr, int flags,
+ const CmdFrame * invoker, int word);
+#endif
typedef struct TclIntStubs {
int magic;
@@ -1343,6 +1375,12 @@ typedef struct TclIntStubs {
void (*tclInitVarHashTable) (TclVarHashTable * tablePtr, Namespace * nsPtr); /* 235 */
void (*tclBackgroundException) (Tcl_Interp * interp, int code); /* 236 */
int (*tclResetCancellation) (Tcl_Interp * interp, int force); /* 237 */
+ int (*tclEvalObjv_NR2) (Tcl_Interp * interp, int result, struct TEOV_record * rootPtr); /* 238 */
+ Tcl_ObjCmdProc *tclNRInterpProc; /* 239 */
+ int (*tclNRInterpProcCore) (Tcl_Interp * interp, Tcl_Obj * procNameObj, int skip, ProcErrorProc errorProc); /* 240 */
+ struct TEOV_record * (*tclNRPushRecord) (Tcl_Interp * interp); /* 241 */
+ void (*tclNRPopAndFreeRecord) (Tcl_Interp * interp); /* 242 */
+ int (*tclNREvalObjEx) (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags, const CmdFrame * invoker, int word); /* 243 */
} TclIntStubs;
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
@@ -2088,6 +2126,30 @@ extern CONST TclIntStubs *tclIntStubsPtr;
#define TclResetCancellation \
(tclIntStubsPtr->tclResetCancellation) /* 237 */
#endif
+#ifndef TclEvalObjv_NR2
+#define TclEvalObjv_NR2 \
+ (tclIntStubsPtr->tclEvalObjv_NR2) /* 238 */
+#endif
+#ifndef TclNRInterpProc
+#define TclNRInterpProc \
+ (*tclIntStubsPtr->tclNRInterpProc) /* 239 */
+#endif
+#ifndef TclNRInterpProcCore
+#define TclNRInterpProcCore \
+ (tclIntStubsPtr->tclNRInterpProcCore) /* 240 */
+#endif
+#ifndef TclNRPushRecord
+#define TclNRPushRecord \
+ (tclIntStubsPtr->tclNRPushRecord) /* 241 */
+#endif
+#ifndef TclNRPopAndFreeRecord
+#define TclNRPopAndFreeRecord \
+ (tclIntStubsPtr->tclNRPopAndFreeRecord) /* 242 */
+#endif
+#ifndef TclNREvalObjEx
+#define TclNREvalObjEx \
+ (tclIntStubsPtr->tclNREvalObjEx) /* 243 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index c681da5..c4f8515 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInterp.c,v 1.86 2008/06/20 20:48:47 dgp Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.87 2008/07/13 09:03:35 msofer Exp $
*/
#include "tclInt.h"
@@ -196,6 +196,9 @@ static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp);
static int AliasObjCmd(ClientData dummy,
Tcl_Interp *currentInterp, int objc,
Tcl_Obj *const objv[]);
+static int AliasNRCmd(ClientData dummy,
+ Tcl_Interp *currentInterp, int objc,
+ Tcl_Obj *const objv[]);
static void AliasObjCmdDeleteProc(ClientData clientData);
static Tcl_Interp * GetInterp(Tcl_Interp *interp, Tcl_Obj *pathPtr);
static Tcl_Interp * GetInterp2(Tcl_Interp *interp, int objc,
@@ -1482,9 +1485,15 @@ AliasCreate(
Tcl_Preserve(slaveInterp);
Tcl_Preserve(masterInterp);
+ if (slaveInterp == masterInterp) {
+ aliasPtr->slaveCmd = TclNR_CreateCommand(slaveInterp,
+ TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr,
+ AliasObjCmdDeleteProc);
+ } else {
aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
TclGetString(namePtr), AliasObjCmd, aliasPtr,
AliasObjCmdDeleteProc);
+ }
if (TclPreventAliasLoop(interp, slaveInterp,
aliasPtr->slaveCmd) != TCL_OK) {
@@ -1739,6 +1748,69 @@ AliasList(
*/
static int
+AliasNRCmd(
+ ClientData clientData, /* Alias record. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument vector. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Alias *aliasPtr = clientData;
+ int prefc, cmdc, i;
+ Tcl_Obj **prefv, **cmdv;
+ int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
+ Tcl_Obj *listPtr;
+ List *listRep;
+ int flags = TCL_EVAL_INVOKE;
+
+ /*
+ * Append the arguments to the command prefix and invoke the command in
+ * the target interp's global namespace.
+ */
+
+ prefc = aliasPtr->objc;
+ prefv = &aliasPtr->objPtr;
+ cmdc = prefc + objc - 1;
+
+ listPtr = Tcl_NewListObj(cmdc, NULL);
+ listRep = listPtr->internalRep.twoPtrValue.ptr1;
+ listRep->elemCount = cmdc;
+ cmdv = &listRep->elements;
+
+ prefv = &aliasPtr->objPtr;
+ memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *)));
+ memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *)));
+
+ for (i=0; i<cmdc; i++) {
+ Tcl_IncrRefCount(cmdv[i]);
+ }
+
+ /*
+ * Use the ensemble rewriting machinery to ensure correct error messages:
+ * only the source command should show, not the full target prefix.
+ */
+
+ if (isRootEnsemble) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = 1;
+ iPtr->ensembleRewrite.numInsertedObjs = prefc;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs += prefc - 1;
+ }
+
+ /*
+ * We are sending a 0-refCount obj, do not need a callback: it will be
+ * cleaned up automatically. But we may need to clear the rootEnsemble
+ * stuff ...
+ */
+
+ if (isRootEnsemble) {
+ TclNR_AddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
+ }
+ return TclNREvalCmd(interp, listPtr, flags);
+}
+
+static int
AliasObjCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
@@ -2542,10 +2614,24 @@ SlaveEval(
if (objc == 1) {
/*
* TIP #280: Make invoker available to eval'd script.
+ *
+ * Do not let any intReps accross, with the exception of
+ * bytecodes. The intrep spoiling is due to happen anyway when
+ * compiling.
*/
Interp *iPtr = (Interp *) interp;
- result = TclEvalObjEx(slaveInterp, objv[0], 0, iPtr->cmdFramePtr, 0);
+
+ objPtr = objv[0];
+ if (objPtr->typePtr
+ && (objPtr->typePtr != &tclByteCodeType)
+ && objPtr->typePtr->freeIntRepProc) {
+ (void) TclGetString(objPtr);
+ TclFreeIntRep(objPtr);
+ objPtr->typePtr = NULL;
+ }
+
+ result = TclEvalObjEx(slaveInterp, objPtr, 0, iPtr->cmdFramePtr, 0);
} else {
objPtr = Tcl_ConcatObj(objc, objv);
Tcl_IncrRefCount(objPtr);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index cf39f90..a0a651b 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -23,7 +23,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.164 2008/05/22 15:22:07 dgp Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.165 2008/07/13 09:03:35 msofer Exp $
*/
#include "tclInt.h"
@@ -169,6 +169,8 @@ static int GetNamespaceFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
static int InvokeImportedCmd(ClientData clientData,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
+static int InvokeImportedNRCmd(ClientData clientData,
+ Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NamespaceChildrenCmd(ClientData dummy,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp,
@@ -212,6 +214,8 @@ static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp,
static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int NsEnsembleImplementationCmd(ClientData clientData,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
+static int NsEnsembleImplementationCmdNR(ClientData clientData,
+ Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr);
static int NsEnsembleStringOrder(const void *strPtr1,
const void *strPtr2);
@@ -224,6 +228,8 @@ static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
static void UnlinkNsPath(Namespace *nsPtr);
+static TclNR_PostProc NsEval_Callback;
+
/*
* This structure defines a Tcl object type that contains a namespace
* reference. It is used in commands that take the name of a namespace as an
@@ -1638,8 +1644,8 @@ DoImport(
}
dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData));
- importedCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
- InvokeImportedCmd, dataPtr, DeleteImportedCmd);
+ importedCmd = TclNR_CreateCommand(interp, Tcl_DStringValue(&ds),
+ InvokeImportedCmd, InvokeImportedNRCmd, dataPtr, DeleteImportedCmd);
dataPtr->realCmdPtr = cmdPtr;
dataPtr->selfPtr = (Command *) importedCmd;
dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
@@ -1876,6 +1882,25 @@ TclGetOriginalCommand(
*/
static int
+InvokeImportedNRCmd(
+ ClientData clientData, /* Points to the imported command's
+ * ImportedCmdData structure. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ register ImportedCmdData *dataPtr = clientData;
+ register Command *realCmdPtr = dataPtr->realCmdPtr;
+
+ if (!realCmdPtr->nreProc) {
+ return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp,
+ objc, objv);
+ }
+ return (*realCmdPtr->nreProc)(realCmdPtr->objClientData, interp,
+ objc, objv);
+}
+
+static int
InvokeImportedCmd(
ClientData clientData, /* Points to the imported command's
* ImportedCmdData structure. */
@@ -2772,6 +2797,16 @@ Tcl_NamespaceObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
+ return TclNR_CallObjProc(interp, TclNRNamespaceObjCmd, clientData, objc, objv);
+}
+
+int
+TclNRNamespaceObjCmd(
+ ClientData clientData, /* Arbitrary value passed to cmd. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
static const char *subCmds[] = {
"children", "code", "current", "delete", "ensemble",
"eval", "exists", "export", "forget", "import",
@@ -3225,12 +3260,42 @@ NamespaceDeleteCmd(
*/
static int
+NsEval_Callback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Namespace *namespacePtr = data[0];
+
+ if (result == TCL_ERROR) {
+ int length = strlen(namespacePtr->fullName);
+ int limit = 200;
+ int overflow = (length > limit);
+ char *cmd = data[1];
+
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (in namespace %s \"%.*s%s\" script line %d)",
+ cmd,
+ (overflow ? limit : length), namespacePtr->fullName,
+ (overflow ? "..." : ""), interp->errorLine));
+ }
+
+ /*
+ * Restore the previous "current" namespace.
+ */
+
+ TclPopStackFrame(interp);
+ return result;
+}
+
+static int
NamespaceEvalCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
+ Interp *iPtr = (Interp *) interp;
Tcl_Namespace *namespacePtr;
CallFrame *framePtr, **framePtrPtr;
Tcl_Obj *objPtr;
@@ -3278,13 +3343,7 @@ NamespaceEvalCmd(
framePtr->objv = objv;
if (objc == 4) {
- /*
- * TIP #280: Make invoker available to eval'd script.
- */
-
- Interp *iPtr = (Interp *) interp;
-
- result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr, 3);
+ objPtr = objv[3];
} else {
/*
* More than one argument: concatenate them together with spaces
@@ -3293,31 +3352,14 @@ NamespaceEvalCmd(
*/
objPtr = Tcl_ConcatObj(objc-3, objv+3);
-
- /*
- * TIP #280: Make invoking context available to eval'd script.
- */
-
- result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0);
}
-
- if (result == TCL_ERROR) {
- int length = strlen(namespacePtr->fullName);
- int limit = 200;
- int overflow = (length > limit);
-
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (in namespace eval \"%.*s%s\" script line %d)",
- (overflow ? limit : length), namespacePtr->fullName,
- (overflow ? "..." : ""), interp->errorLine));
- }
-
+
/*
- * Restore the previous "current" namespace.
+ * TIP #280: Make invoking context available to eval'd script.
*/
-
- TclPopStackFrame(interp);
- return result;
+
+ TclNR_AddCallback(interp, NsEval_Callback, namespacePtr, "eval", NULL, NULL);
+ return TclNREvalObjEx(interp, objPtr, 0, iPtr->cmdFramePtr, 3);
}
/*
@@ -3675,6 +3717,7 @@ NamespaceInscopeCmd(
Tcl_Namespace *namespacePtr;
CallFrame *framePtr, **framePtrPtr;
int i, result;
+ Tcl_Obj *cmdObjPtr;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
@@ -3712,10 +3755,10 @@ NamespaceInscopeCmd(
*/
if (objc == 4) {
- result = Tcl_EvalObjEx(interp, objv[3], 0);
+ cmdObjPtr = objv[3];
} else {
Tcl_Obj *concatObjv[2];
- register Tcl_Obj *listPtr, *cmdObjPtr;
+ register Tcl_Obj *listPtr;
listPtr = Tcl_NewListObj(0, NULL);
for (i = 4; i < objc; i++) {
@@ -3728,27 +3771,11 @@ NamespaceInscopeCmd(
concatObjv[0] = objv[3];
concatObjv[1] = listPtr;
cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
- result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT);
Tcl_DecrRefCount(listPtr); /* We're done with the list object. */
}
- if (result == TCL_ERROR) {
- int length = strlen(namespacePtr->fullName);
- int limit = 200;
- int overflow = (length > limit);
-
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (in namespace inscope \"%.*s%s\" script line %d)",
- (overflow ? limit : length), namespacePtr->fullName,
- (overflow ? "..." : ""), interp->errorLine));
- }
-
- /*
- * Restore the previous "current" namespace.
- */
-
- TclPopStackFrame(interp);
- return result;
+ TclNR_AddCallback(interp, NsEval_Callback, namespacePtr, "inscope", NULL, NULL);
+ return TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0);
}
/*
@@ -5293,8 +5320,9 @@ Tcl_CreateEnsemble(
ensemblePtr->subcommandDict = NULL;
ensemblePtr->flags = flags;
ensemblePtr->unknownHandler = NULL;
- ensemblePtr->token = Tcl_CreateObjCommand(interp, name,
- NsEnsembleImplementationCmd, ensemblePtr, DeleteEnsembleConfig);
+ ensemblePtr->token = TclNR_CreateCommand(interp, name,
+ NsEnsembleImplementationCmd, NsEnsembleImplementationCmdNR,
+ ensemblePtr, DeleteEnsembleConfig);
ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles;
nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr;
@@ -6013,6 +6041,32 @@ NsEnsembleImplementationCmd(
int objc,
Tcl_Obj *const objv[])
{
+ return TclNR_CallObjProc(interp, NsEnsembleImplementationCmdNR,
+ clientData, objc, objv);
+}
+
+int
+TclClearRootEnsemble(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ iPtr->ensembleRewrite.sourceObjs = NULL;
+ iPtr->ensembleRewrite.numRemovedObjs = 0;
+ iPtr->ensembleRewrite.numInsertedObjs = 0;
+
+ return result;
+}
+
+static int
+NsEnsembleImplementationCmdNR(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
EnsembleConfig *ensemblePtr = clientData;
/* The ensemble itself. */
Tcl_Obj **tempObjv; /* Space used to construct the list of
@@ -6179,8 +6233,9 @@ NsEnsembleImplementationCmd(
{
Interp *iPtr = (Interp *) interp;
- int isRootEnsemble;
- Tcl_Obj *copyObj;
+ int isRootEnsemble, i, tempObjc;
+ Tcl_Obj *copyPtr;
+ List *listRepPtr;
/*
* Get the prefix that we're rewriting to. To do this we need to
@@ -6189,8 +6244,23 @@ NsEnsembleImplementationCmd(
* elements in the list.
*/
- copyObj = TclListObjCopy(NULL, prefixObj);
- TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
+ TclListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv);
+
+ tempObjc = objc - 2 + prefixObjc;
+ copyPtr = Tcl_NewListObj(tempObjc, NULL);
+ if (tempObjc > 0) {
+ listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1;
+ listRepPtr->elemCount = tempObjc;
+ tempObjv = &listRepPtr->elements;
+
+ memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc);
+ memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2));
+
+ for (i=0; i < tempObjc; i++) {
+ Tcl_IncrRefCount(tempObjv[i]);
+ }
+ }
+ Tcl_DecrRefCount(prefixObj);
/*
* Record what arguments the script sent in so that things like
@@ -6214,36 +6284,15 @@ NsEnsembleImplementationCmd(
}
/*
- * Allocate a workspace and build the list of arguments to pass to the
- * target command in it.
- */
-
- tempObjv = (Tcl_Obj **) TclStackAlloc(interp,
- (int) sizeof(Tcl_Obj *) * (objc - 2 + prefixObjc));
- memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc);
- memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2));
-
- /*
* Hand off to the target command.
*/
- result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv,
- TCL_EVAL_INVOKE);
-
- /*
- * Clean up.
- */
-
- TclStackFree(interp, tempObjv);
- Tcl_DecrRefCount(copyObj);
if (isRootEnsemble) {
- iPtr->ensembleRewrite.sourceObjs = NULL;
- iPtr->ensembleRewrite.numRemovedObjs = 0;
- iPtr->ensembleRewrite.numInsertedObjs = 0;
+ TclNR_AddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
}
+
+ return TclNREvalCmd(interp, copyPtr, TCL_EVAL_INVOKE);
}
- Tcl_DecrRefCount(prefixObj);
- return result;
unknownOrAmbiguousSubcommand:
/*
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 42f65ba..90cac16 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -12,11 +12,21 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.142 2008/06/13 05:45:14 mistachkin Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.143 2008/07/13 09:03:35 msofer Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
+#include "tclNRE.h"
+
+typedef struct {
+ int isRootEnsemble;
+ Command cmd;
+ ExtraFrameInfo efi;
+} ApplyExtraData;
+
+static TclNR_PostProc ApplyNR2;
+static TclNR_PostProc InterpProcNR2;
/*
* Prototypes for static functions in this file
@@ -47,6 +57,8 @@ static int ProcCompileProc(Tcl_Interp *interp, Proc *procPtr,
const char *description, const char *procName,
Proc **procPtrPtr);
+static TclNR_PostProc Uplevel_Callback;
+
/*
* The ProcBodyObjType type
*/
@@ -185,9 +197,8 @@ Tcl_ProcObjCmd(
}
Tcl_DStringAppend(&ds, procName, -1);
- cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
- TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);
-
+ cmd = TclNR_CreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc,
+ TclNRInterpProc, (ClientData) procPtr, TclProcDeleteProc);
Tcl_DStringFree(&ds);
/*
@@ -864,6 +875,27 @@ TclObjGetFrame(
*----------------------------------------------------------------------
*/
+static int
+Uplevel_Callback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CallFrame *savedVarFramePtr = data[0];
+
+ if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"uplevel\" body line %d)", interp->errorLine));
+ }
+
+ /*
+ * Restore the variable frame, and return.
+ */
+
+ ((Interp *)interp)->varFramePtr = savedVarFramePtr;
+ return result;
+}
+
/* ARGSUSED */
int
Tcl_UplevelObjCmd(
@@ -872,9 +904,21 @@ Tcl_UplevelObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
+ return TclNR_CallObjProc(interp, TclNRUplevelObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRUplevelObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+
register Interp *iPtr = (Interp *) interp;
int result;
CallFrame *savedVarFramePtr, *framePtr;
+ Tcl_Obj *objPtr;
if (objc < 2) {
uplevelSyntax:
@@ -908,7 +952,7 @@ Tcl_UplevelObjCmd(
*/
if (objc == 1) {
- result = Tcl_EvalObjEx(interp, objv[0], 0);
+ objPtr = objv[0];
} else {
/*
* More than one argument: concatenate them together with spaces
@@ -916,22 +960,11 @@ Tcl_UplevelObjCmd(
* object when it decrements its refcount after eval'ing it.
*/
- Tcl_Obj *objPtr;
-
objPtr = Tcl_ConcatObj(objc, objv);
- result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
- }
- if (result == TCL_ERROR) {
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (\"uplevel\" body line %d)", interp->errorLine));
}
- /*
- * Restore the variable frame, and return.
- */
-
- iPtr->varFramePtr = savedVarFramePtr;
- return result;
+ TclNR_AddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL, NULL);
+ return TclNREvalObjEx(interp, objPtr, 0, NULL, 0);
}
/*
@@ -963,7 +996,6 @@ TclFindProc(
const char *procName) /* Name of desired procedure. */
{
Tcl_Command cmd;
- Tcl_Command origCmd;
Command *cmdPtr;
cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, NULL, /*flags*/ 0);
@@ -972,14 +1004,7 @@ TclFindProc(
}
cmdPtr = (Command *) cmd;
- origCmd = TclGetOriginalCommand(cmd);
- if (origCmd != NULL) {
- cmdPtr = (Command *) origCmd;
- }
- if (cmdPtr->objProc != TclObjInterpProc) {
- return NULL;
- }
- return (Proc *) cmdPtr->objClientData;
+ return TclIsProc(cmdPtr);
}
/*
@@ -1010,7 +1035,7 @@ TclIsProc(
if (origCmd != NULL) {
cmdPtr = (Command *) origCmd;
}
- if (cmdPtr->objProc == TclObjInterpProc) {
+ if (cmdPtr->deleteProc == TclProcDeleteProc) {
return (Proc *) cmdPtr->objClientData;
}
return (Proc *) 0;
@@ -1581,6 +1606,23 @@ PushProcCallFrame(
return TCL_OK;
}
+
+static int
+TclNR_BC(
+ Tcl_Interp * interp,
+ ByteCode *codePtr,
+ TclNR_PostProc *postProcPtr,
+ Tcl_Obj *procNameObj,
+ ProcErrorProc errorProc)
+{
+ TEOV_record *recordPtr = TOP_RECORD(interp);
+
+ recordPtr->type = TCL_NR_BC_TYPE;
+ recordPtr->data.codePtr = codePtr;
+ TclNR_AddCallback(interp, postProcPtr, procNameObj, errorProc, NULL, NULL);
+ return TCL_OK;
+}
+
/*
*----------------------------------------------------------------------
*
@@ -1610,6 +1652,10 @@ TclObjInterpProc(
{
int result;
+ /*
+ * Not used in the core; external interface for iTcl and XOTcl
+ */
+
result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0);
if (result == TCL_OK) {
return TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError);
@@ -1617,6 +1663,26 @@ TclObjInterpProc(
return TCL_ERROR;
}
}
+
+int
+TclNRInterpProc(
+ ClientData clientData, /* Record describing procedure to be
+ * interpreted. */
+ register Tcl_Interp *interp,/* Interpreter in which procedure was
+ * invoked. */
+ int objc, /* Count of number of arguments to this
+ * procedure. */
+ Tcl_Obj *CONST objv[]) /* Argument value objects. */
+{
+ int result;
+
+ result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0);
+ if (result == TCL_OK) {
+ return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
+ } else {
+ return TCL_ERROR;
+ }
+}
/*
*----------------------------------------------------------------------
@@ -1646,14 +1712,59 @@ TclObjInterpProcCore(
ProcErrorProc errorProc) /* How to convert results from the script into
* results of the overall procedure. */
{
+ /*
+ * Not used in the core; external interface for TclOO
+ */
+
+ Interp *iPtr = (Interp *) interp;
+ TEOV_record record, *rootPtr;
+ int result;
+
+ /*
+ * Put a top record NOT ON THE TCL STACK! Note that TclNRInterpProcCore
+ * assumes it can free the CallFrame in the error case, there cannot be
+ * anything else on top of that. We use a C-stack record, it could also be
+ * ckalloc'ed or anything else, just NOT TclStackAlloc.
+ */
+
+ rootPtr = TOP_RECORD(iPtr);
+ TOP_RECORD(iPtr) = &record;
+ result = TclNRInterpProcCore(interp, procNameObj, skip, errorProc);
+ TOP_RECORD(iPtr) = rootPtr;
+
+ if (result == TCL_OK) {
+ result = TclExecuteByteCode(interp, record.data.codePtr);
+ result = TclEvalObjv_NR2(interp, result, rootPtr);
+ result = InterpProcNR2(&record.callbackPtr->data0, interp, result);
+ TclSmallFree(record.callbackPtr);
+ }
+ return result;
+}
+
+int
+TclNRInterpProcCore(
+ register Tcl_Interp *interp,/* Interpreter in which procedure was
+ * invoked. */
+ Tcl_Obj *procNameObj, /* Procedure name for error reporting. */
+ int skip, /* Number of initial arguments to be skipped,
+ * i.e., words in the "command name". */
+ ProcErrorProc errorProc) /* How to convert results from the script into
+ * results of the overall procedure. */
+{
Interp *iPtr = (Interp *) interp;
register Proc *procPtr = iPtr->varFramePtr->procPtr;
int result;
CallFrame *freePtr;
+ ByteCode *codePtr;
result = InitArgsAndLocals(interp, procNameObj, skip);
if (result != TCL_OK) {
- goto procDone;
+ freePtr = iPtr->framePtr;
+ Tcl_PopCallFrame(interp); /* Pop but do not free. */
+ TclStackFree(interp, freePtr->compiledLocals);
+ /* Free compiledLocals. */
+ TclStackFree(interp, freePtr); /* Free CallFrame. */
+ return TCL_ERROR;
}
#if defined(TCL_COMPILE_DEBUG)
@@ -1703,36 +1814,37 @@ TclObjInterpProcCore(
TclResetCancellation(interp, 0);
procPtr->refCount++;
- iPtr->numLevels++;
+ codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
+ int l;
+
+ l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 2 : 1;
+ TCL_DTRACE_PROC_ENTRY(TclGetString(procNameObj),
+ iPtr->varFramePtr->objc - l,
+ (Tcl_Obj **)(iPtr->varFramePtr->objv + l));
+ }
- if (TclInterpReady(interp) == TCL_ERROR) {
- result = TCL_ERROR;
- } else {
- register ByteCode *codePtr =
- procPtr->bodyPtr->internalRep.otherValuePtr;
+ TclNR_BC(interp, codePtr, InterpProcNR2, procNameObj, errorProc);
+
+ return TCL_OK;
+}
- codePtr->refCount++;
- if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
- int l;
-
- l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 2 : 1;
- TCL_DTRACE_PROC_ENTRY(TclGetString(procNameObj),
- iPtr->varFramePtr->objc - l,
- (Tcl_Obj **)(iPtr->varFramePtr->objv + l));
- }
- result = TclExecuteByteCode(interp, codePtr);
- if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
- TCL_DTRACE_PROC_RETURN(TclGetString(procNameObj), result);
- }
- codePtr->refCount--;
- if (codePtr->refCount <= 0) {
- TclCleanupByteCode(codePtr);
- }
+static int
+InterpProcNR2(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ Proc *procPtr = iPtr->varFramePtr->procPtr;
+ CallFrame *freePtr;
+ Tcl_Obj *procNameObj = data[0];
+ ProcErrorProc errorProc = data[1];
+
+ if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
+ TCL_DTRACE_PROC_RETURN(TclGetString(procNameObj), result);
}
-
- iPtr->numLevels--;
- procPtr->refCount--;
- if (procPtr->refCount <= 0) {
+ if (--procPtr->refCount <= 0) {
TclProcCleanupProc(procPtr);
}
@@ -1798,7 +1910,6 @@ TclObjInterpProcCore(
TclGetString(r), r);
}
- procDone:
/*
* Free the stack-allocated compiled locals and CallFrame. It is important
* to pop the call frame without freeing it first: the compiledLocals
@@ -1812,6 +1923,7 @@ TclObjInterpProcCore(
TclStackFree(interp, freePtr->compiledLocals);
/* Free compiledLocals. */
TclStackFree(interp, freePtr); /* Free CallFrame. */
+
return result;
}
@@ -2591,13 +2703,23 @@ Tcl_ApplyObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
+ return TclNR_CallObjProc(interp, TclNRApplyObjCmd, dummy, objc, objv);
+}
+
+
+int
+TclNRApplyObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
+{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = NULL;
Tcl_Obj *lambdaPtr, *nsObjPtr;
int result, isRootEnsemble;
- Command cmd;
Tcl_Namespace *nsPtr;
- ExtraFrameInfo efi;
+ ApplyExtraData *extraPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?");
@@ -2615,6 +2737,12 @@ Tcl_ApplyObjCmd(
}
#define JOE_EXTENSION 0
+/*
+ * Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT
+ * ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt
+ * the code. (MS)
+ */
+
#if JOE_EXTENSION
else {
/*
@@ -2641,8 +2769,21 @@ Tcl_ApplyObjCmd(
procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
}
- memset(&cmd, 0, sizeof(Command));
- procPtr->cmdPtr = &cmd;
+ /*
+ * Find the namespace where this lambda should run, and push a call frame
+ * for that namespace. Note that TclObjInterpProc() will pop it.
+ */
+
+ nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2;
+ result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ extraPtr = TclStackAlloc(interp, sizeof(ApplyExtraData));
+ memset(&extraPtr->cmd, 0, sizeof(Command));
+ procPtr->cmdPtr = &extraPtr->cmd;
+ extraPtr->cmd.nsPtr = (Namespace *) nsPtr;
/*
* TIP#280 (semi-)HACK!
@@ -2654,24 +2795,11 @@ Tcl_ApplyObjCmd(
* 'hPtr', and lambda's never.
*/
- efi.length = 1;
- efi.fields[0].name = "lambda";
- efi.fields[0].proc = NULL;
- efi.fields[0].clientData = lambdaPtr;
- cmd.clientData = &efi;
-
- /*
- * Find the namespace where this lambda should run, and push a call frame
- * for that namespace. Note that TclObjInterpProc() will pop it.
- */
-
- nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2;
- result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
- if (result != TCL_OK) {
- return result;
- }
-
- cmd.nsPtr = (Namespace *) nsPtr;
+ extraPtr->efi.length = 1;
+ extraPtr->efi.fields[0].name = "lambda";
+ extraPtr->efi.fields[0].proc = NULL;
+ extraPtr->efi.fields[0].clientData = lambdaPtr;
+ extraPtr->cmd.clientData = &extraPtr->efi;
isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
if (isRootEnsemble) {
@@ -2681,18 +2809,43 @@ Tcl_ApplyObjCmd(
} else {
iPtr->ensembleRewrite.numInsertedObjs -= 1;
}
+ extraPtr->isRootEnsemble = isRootEnsemble;
result = PushProcCallFrame((ClientData) procPtr, interp, objc, objv, 1);
if (result == TCL_OK) {
- result = TclObjInterpProcCore(interp, objv[1], 2, &MakeLambdaError);
+ result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError);
+ if (result == TCL_OK) {
+ /* Fix the recordPtr! */
+
+ TEOV_record *recordPtr = TOP_RECORD(iPtr);
+ recordPtr->callbackPtr->procPtr = ApplyNR2;
+ recordPtr->callbackPtr->data2 = extraPtr;
+ }
}
+ if (result != TCL_OK) {
+ if (isRootEnsemble) {
+ iPtr->ensembleRewrite.sourceObjs = NULL;
+ }
+ TclStackFree(interp, extraPtr);
+ }
+ return result;
+}
- if (isRootEnsemble) {
- iPtr->ensembleRewrite.sourceObjs = NULL;
- iPtr->ensembleRewrite.numRemovedObjs = 0;
- iPtr->ensembleRewrite.numInsertedObjs = 0;
+static int
+ApplyNR2(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ ApplyExtraData *extraPtr = data[2];
+
+ result = InterpProcNR2(data, interp, result);
+
+ if (extraPtr->isRootEnsemble) {
+ ((Interp *) interp)->ensembleRewrite.sourceObjs = NULL;
}
+ TclStackFree(interp, extraPtr);
return result;
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index b02c4d0..61e8ad1 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.155 2008/07/08 17:52:17 dgp Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.156 2008/07/13 09:03:35 msofer Exp $
*/
#include "tclInt.h"
@@ -307,6 +307,12 @@ static const TclIntStubs tclIntStubs = {
TclInitVarHashTable, /* 235 */
TclBackgroundException, /* 236 */
TclResetCancellation, /* 237 */
+ TclEvalObjv_NR2, /* 238 */
+ &TclNRInterpProc, /* 239 */
+ TclNRInterpProcCore, /* 240 */
+ TclNRPushRecord, /* 241 */
+ TclNRPopAndFreeRecord, /* 242 */
+ TclNREvalObjEx, /* 243 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
@@ -1102,6 +1108,12 @@ static const TclStubs tclStubs = {
Tcl_AppendPrintfToObj, /* 579 */
Tcl_CancelEval, /* 580 */
Tcl_Canceled, /* 581 */
+ TclNR_CreateCommand, /* 582 */
+ TclNR_EvalObj, /* 583 */
+ TclNR_EvalObjv, /* 584 */
+ TclNR_ObjProc, /* 585 */
+ TclNR_AddCallback, /* 586 */
+ TclNR_CallObjProc, /* 587 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c
index db390a1..d346d59 100644
--- a/generic/tclTestProcBodyObj.c
+++ b/generic/tclTestProcBodyObj.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTestProcBodyObj.c,v 1.6 2008/04/27 22:21:32 dkf Exp $
+ * RCS: @(#) $Id: tclTestProcBodyObj.c,v 1.7 2008/07/13 09:03:35 msofer Exp $
*/
#include "tclInt.h"
@@ -255,10 +255,10 @@ ProcBodyTestProcObjCmd(
/*
* check that this is a procedure and not a builtin command:
- * If a procedure, cmdPtr->objProc is TclObjInterpProc.
+ * If a procedure, cmdPtr->objClientData is TclIsProc(cmdPtr).
*/
- if (cmdPtr->objProc != TclGetObjInterpProc()) {
+ if (cmdPtr->objClientData != TclIsProc(cmdPtr)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"command \"", fullName, "\" is not a Tcl procedure", NULL);
return TCL_ERROR;
generated by cgit v0.12 at 2024-11-22 21:16:01 (GMT)