diff options
author | msofer <msofer@noemail.net> | 2008-07-13 09:03:30 (GMT) |
---|---|---|
committer | msofer <msofer@noemail.net> | 2008-07-13 09:03:30 (GMT) |
commit | ce93a2b1f3a340a1227c55859fbc32897d8d8da9 (patch) | |
tree | 7d872fa5186b327990fa96d969a3b092780f38d2 /generic/tclInterp.c | |
parent | a3d41e2e6e07b38abf31367960d5df505f4baf69 (diff) | |
download | tcl-ce93a2b1f3a340a1227c55859fbc32897d8d8da9.zip tcl-ce93a2b1f3a340a1227c55859fbc32897d8d8da9.tar.gz tcl-ce93a2b1f3a340a1227c55859fbc32897d8d8da9.tar.bz2 |
NRE implementation [Patch 2017110]
FossilOrigin-Name: a646e4c362a574666638b06521668fc53952bd72
Diffstat (limited to 'generic/tclInterp.c')
-rw-r--r-- | generic/tclInterp.c | 90 |
1 files changed, 88 insertions, 2 deletions
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); |