From 5765c1e39239c149fc739e8e48b3d554901318e7 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 11 Feb 2018 19:19:46 +0000 Subject: Refine documentation for Tcl_NR* functions. --- doc/Eval.3 | 8 +- doc/NRE.3 | 260 ++++++++++++++++++++----------------------------------------- 2 files changed, 88 insertions(+), 180 deletions(-) diff --git a/doc/Eval.3 b/doc/Eval.3 index 191bace..e241794 100644 --- a/doc/Eval.3 +++ b/doc/Eval.3 @@ -176,10 +176,10 @@ it is faster to execute the script directly. .TP 23 \fBTCL_EVAL_GLOBAL\fR . -If this flag is set, the script is processed at global level. This -means that it is evaluated in the global namespace and its variable -context consists of global variables only (it ignores any Tcl -procedures that are active). +If this flag is set, the script is evaluated in the global namespace instead of +the current namespace and its variable context consists of global variables +only (it ignores any Tcl procedures that are active). +.\" TODO: document TCL_EVAL_INVOKE and TCL_EVAL_NOERR. .SH "MISCELLANEOUS DETAILS" .PP diff --git a/doc/NRE.3 b/doc/NRE.3 index ff0d108..6078a53 100644 --- a/doc/NRE.3 +++ b/doc/NRE.3 @@ -1,5 +1,6 @@ .\" .\" Copyright (c) 2008 by Kevin B. Kenny. +.\" Copyright (c) 2018 by Nathan Coulter. .\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -38,43 +39,39 @@ void .SH ARGUMENTS .AS Tcl_CmdDeleteProc *interp in .AP Tcl_Interp *interp in -Interpreter in which to create or evaluate a command. +The relevant Interpreter. .AP char *cmdName in -Name of a new command to create. +Name of the command to create. .AP Tcl_ObjCmdProc *proc in -Implementation of a command that will be called whenever \fIcmdName\fR -is invoked as a command in the unoptimized way. +Called in order to evaluate a command. Is often just a small wrapper that uses +\fBTcl_NRCallObjProc\fR to call \fInreProc\fR using a new trampoline. Behaves +in the same way as the \fIproc\fR argument to \fBTcl_CreateObjCommand\fR(3) +(\fIq.v.\fR). .AP Tcl_ObjCmdProc *nreProc in -Implementation of a command that will be called whenever \fIcmdName\fR -is invoked and requested to conserve the C stack. +Called instead of \fIproc\fR when a trampoline is already in use. .AP ClientData clientData in -Arbitrary one-word value that will be passed to \fIproc\fR, \fInreProc\fR, -\fIdeleteProc\fR and \fIobjProc\fR. +Arbitrary one-word value passed to \fIproc\fR, \fInreProc\fR, \fIdeleteProc\fR +and \fIobjProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in/out -Procedure to call before \fIcmdName\fR is deleted from the interpreter. -This procedure allows for command-specific cleanup. If \fIdeleteProc\fR -is \fBNULL\fR, then no procedure is called before the command is deleted. +Called before \fIcmdName\fR is deleted from the interpreter, allowing for +command-specific cleanup. May be NULL. .AP int objc in -Count of parameters provided to the implementation of a command. +Number of items in \fIobjv\fR. .AP Tcl_Obj **objv in -Pointer to an array of Tcl values. Each value holds the value of a -single word in the command to execute. +Words in the command. .AP Tcl_Obj *objPtr in -Pointer to a Tcl_Obj whose value is a script or expression to execute. +A script or expression to evaluate. .AP int flags in -ORed combination of flag bits that specify additional options. -\fBTCL_EVAL_GLOBAL\fR is the only flag that is currently supported. -.\" TODO: This is a lie. But kbk didn't grasp TCL_EVAL_INVOKE and -.\" TCL_EVAL_NOERR well enough to document them. +As described for \fITcl_EvalObjv\fR. +.PP .AP Tcl_Command cmd in -Token for a command that is to be used instead of the currently -executing command. +Token to use instead of one derived from the first word of \fIobjv\fR in order +to evaluate a command. .AP Tcl_Obj *resultPtr out -Pointer to an unshared Tcl_Obj where the result of expression -evaluation is written. +Pointer to an unshared Tcl_Obj where the result of the evaluation is stored if +the return code is TCL_OK. .AP Tcl_NRPostProc *postProcPtr in -Pointer to a function that will be invoked when the command currently -executing in the interpreter designated by \fIinterp\fR completes. +A function to push. .AP ClientData data0 in .AP ClientData data1 in .AP ClientData data2 in @@ -84,98 +81,51 @@ to the function designated by \fIpostProcPtr\fR when it is invoked. .BE .SH DESCRIPTION .PP -This series of C functions provides an interface whereby commands that -are implemented in C can be evaluated, and invoke Tcl commands scripts -and scripts, without consuming space on the C stack. The non-recursive -evaluation is done by installing a \fItrampoline\fR, a small piece of -code that invokes a command or script, and then executes a series of -callbacks when the command or script returns. -.PP -The \fBTcl_NRCreateCommand\fR function creates a Tcl command in the -interpreter designated by \fIinterp\fR that is prepared to handle -nonrecursive evaluation with a trampoline. The \fIcmdName\fR argument -gives the name of the new command. If \fIcmdName\fR contains any -namespace qualifiers, then the new command is added to the specified -namespace; otherwise, it is added to the global namespace. \fIproc\fR -gives the procedure that will be called when the interpreter wishes to -evaluate the command in an unoptimized manner, and \fInreProc\fR is -the procedure that will be called when the interpreter wishes to -evaluate the command using a trampoline. \fIdeleteProc\fR is a -function that will be called before the command is deleted from the -interpreter. When any of the three functions is invoked, it is passed -the \fIclientData\fR parameter. -.PP -\fBTcl_NRCreateCommand\fR deletes any existing command -\fIname\fR already associated with the interpreter -(however see below for an exception where the existing command -is not deleted). -It returns a token that may be used to refer -to the command in subsequent calls to \fBTcl_GetCommandName\fR. -If \fBTcl_NRCreateCommand\fR is called for an interpreter that is in -the process of being deleted, then it does not create a new command, -does not delete any existing command of the same name, and returns NULL. -.PP -The \fIproc\fR and \fInreProc\fR function are expected to conform to -all the rules set forth for the \fIproc\fR argument to -\fBTcl_CreateObjCommand\fR(3) (\fIq.v.\fR). -.PP -When a command that is written to cope with evaluation via trampoline -is invoked without a trampoline on the stack, it will usually respond -to the invocation by creating a trampoline and calling the -trampoline-enabled implementation of the same command. This call is done by -means of \fBTcl_NRCallObjProc\fR. In the call to -\fBTcl_NRCallObjProc\fR, the \fIinterp\fR, \fIclientData\fR, -\fIobjc\fR and \fIobjv\fR parameters should be the same ones that were -passed to \fIproc\fR. The \fInreProc\fR parameter should designate the -trampoline-enabled implementation of the command. -.PP -\fBTcl_NREvalObj\fR arranges for the script contained in \fIobjPtr\fR -to be evaluated in the interpreter designated by \fIinterp\fR after -the current command (which must be trampoline-enabled) returns. It is -the method by which a command may invoke a script without consuming -space on the C stack. Similarly, \fBTcl_NREvalObjv\fR arranges to -invoke a single Tcl command whose words have already been separated -and substituted. The \fIobjc\fR and \fIobjv\fR parameters give the -words of the command to be evaluated when execution reaches the -trampoline. -.PP -\fBTcl_NRCmdSwap\fR allows for trampoline evaluation of a command whose -resolution is already known. The \fIcmd\fR parameter gives a -\fBTcl_Command\fR token (returned from \fBTcl_CreateObjCommand\fR or -\fBTcl_GetCommandFromObj\fR) identifying the command to be invoked in -the trampoline; this command must match the word in \fIobjv[0]\fR. -The remaining arguments are as for \fBTcl_NREvalObjv\fR. -.PP -\fBTcl_NREvalObj\fR, \fBTcl_NREvalObjv\fR and \fBTcl_NRCmdSwap\fR -all accept a \fIflags\fR parameter, which is an OR-ed-together set of -bits to control evaluation. At the present time, the only supported flag -available to callers is \fBTCL_EVAL_GLOBAL\fR. -.\" TODO: Again, this is a lie. Do we want to explain TCL_EVAL_INVOKE -.\" and TCL_EVAL_NOERR? -If the \fBTCL_EVAL_GLOBAL\fR flag is set, the script or command is -evaluated in the global namespace. If it is not set, it is evaluated -in the current namespace. -.PP -\fBTcl_NRExprObj\fR arranges for the expression contained in \fIobjPtr\fR -to be evaluated in the interpreter designated by \fIinterp\fR after -the current command (which must be trampoline-enabled) returns. It is -the method by which a command may evaluate a Tcl expression without consuming -space on the C stack. The argument \fIresultPtr\fR is a pointer to an -unshared Tcl_Obj where the result of expression evaluation is to be written. -If expression evaluation returns any code other than TCL_OK, the -\fIresultPtr\fR value is left untouched. -.PP -All of the routines return \fBTCL_OK\fR if command or expression invocation -has been scheduled successfully. If for any reason the scheduling cannot -be completed (for example, if the interpreter is unable to find -the requested command), they return \fBTCL_ERROR\fR with an -appropriate message left in the interpreter's result. -.PP -\fBTcl_NRAddCallback\fR arranges to have a C function called when the -current trampoline-enabled command in the Tcl interpreter designated -by \fIinterp\fR returns. The \fIpostProcPtr\fR argument is a pointer -to the callback function, which must have arguments and return value -consistent with the \fBTcl_NRPostProc\fR data type: +These functions provide an interface to the function stack that an interpreter +iterates through to evaluate commands. The routine behind a command is +implemented by an initial function and any additional functions that the +routine pushes onto the stack as it progresses. The interpreter itself pushes +functions onto the stack to react to the end of a routine and to exercise other +forms of control such as switching between in-progress stacks and the +evaluation of other scripts at additional levels without adding frames to the C +stack. To execute a routine, the initial function for the routine is called +and then a small bit of code called a \fItrampoline\fR iteratively takes +functions off the stack and calls them, using the value of the last call as the +value of the routine. +.PP +\fBTcl_NRCallObjProc\fR calls \fInreProc\fR using a new trampoline. +.PP +\fBTcl_NRCreateCommand\fR, an alternative to \fBTcl_CreateObjCommand\fR, +resolves \fIcmdName\fR, which may contain namespace qualifiers, relative to the +current namespace, creates a command by that name, and returns a token for the +command which may be used in subsequent calls to \fBTcl_GetCommandName\fR. +Except for a few cases noted below any existing command by the same name is +first deleted. If \fIinterp\fR is in the process of being deleted +\fBTcl_NRCreateCommand\fR does not create any command, does not delete any +command, and returns NULL. +.PP +\fBTcl_NREvalObj\fR pushes a function that is like \fBTcl_EvalObjEx\fR but +consumes no space on the C stack. +.PP +\fBTcl_NREvalObjv\fR pushes a function that is like \fBTcl_EvalObjv\fR but +consumes no space on the C stack. +.PP +\fBTcl_NRCmdSwap\fR is like \fBTcl_NREvalObjv\fR, but uses \fIcmd\fR, a token +previously returned by \fBTcl_CreateObjCommand\fR or +\fBTcl_GetCommandFromObj\fR, instead of resolving the first word of \fIobjv\fR. +. The name of this command must be the same as \fIobjv[0]\fR. +.PP +\fBTcl_NRExprObj\fR pushes a function that evaluates \fIobjPtr\fR as an +expression in the same manner as \fBTcl_ExprObj\fR but without consuming space +on the C stack. +.PP +All of the functions return \fBTCL_OK\fR if the evaluation of the script, +command, or expression has been scheduled successfully. Otherwise (for example +if the command name cannot be resolved), they return \fBTCL_ERROR\fR and store +a message as the interpreter's result. +.PP +\fBTcl_NRAddCallback\fR pushes \fIpostProcPtr\fR. The signature for +\fBTcl_NRPostProc\fR is: .PP .CS typedef int @@ -185,25 +135,13 @@ typedef int int \fIresult\fR); .CE .PP -When the trampoline invokes the callback function, the \fIdata\fR -parameter will point to an array containing the four one-word -quantities that were passed to \fBTcl_NRAddCallback\fR in the -\fIdata0\fR through \fIdata3\fR parameters. The Tcl interpreter will -be designated by the \fIinterp\fR parameter, and the \fIresult\fR -parameter will contain the result (\fBTCL_OK\fR, \fBTCL_ERROR\fR, -\fBTCL_RETURN\fR, \fBTCL_BREAK\fR or \fBTCL_CONTINUE\fR) that was -returned by the command evaluation. The callback function is expected, -in turn, either to return a \fIresult\fR to control further evaluation. -.PP -Multiple \fBTcl_NRAddCallback\fR invocations may request multiple -callbacks, which may be to the same or different callback -functions. If multiple callbacks are requested, they are executed in -last-in, first-out order, that is, the most recently requested -callback is executed first. +\fIdata\fR is a pointer to an array containing \fIdata0\fR through \fIdata3\fR. +\fIresult\fR is the value returned by the previous function implementing part +the routine. .SH EXAMPLE .PP -The usual pattern for Tcl commands that invoke other Tcl commands -is something like: +The following command uses \fBTcl_EvalObjEx\fR, which consumes space on the C +stack, to evalute a script: .PP .CS int @@ -228,28 +166,17 @@ int \fITheCmdOldObjProc\fR, clientData, TheCmdDeleteProc); .CE .PP -To enable a command like this one for trampoline-based evaluation, -it must be split into three pieces: -.IP \(bu -A non-trampoline implementation, \fITheCmdNewObjProc\fR, -which will simply create a trampoline -and invoke the trampoline-based implementation. -.IP \(bu -A trampoline-enabled implementation, \fITheCmdNRObjProc\fR. This -function will perform the initialization, request that the trampoline -call the postprocessing routine after command evaluation, and finally, -request that the trampoline call the inner command. -.IP \(bu -A postprocessing routine, \fITheCmdPostProc\fR. This function will -perform the postprocessing formerly done after the return from the -inner command in \fITheCmdObjProc\fR. -.PP -The non-trampoline implementation is simple and stylized, containing -a single statement: +To avoid consuming space on the C stack, \fITheCmdOldObjProc\fR is renamed to +\fITheCmdNRObjProc\fR and the postprocessing step is split into a separate +function, \fITheCmdPostProc\fR, which is pushed onto the function stack. +\fITcl_EvalObjEx\fR is replaced with \fITcl_NREvalObj\fR, which uses a +trampoline instead of consuming space on the C stack. A new version of +\fITheCmdOldObjProc\fR is just a a wrapper that uses \fBTcl_NRCallObjProc\fR to +call \fITheCmdNRObjProc\fR: .PP .CS int -\fITheCmdNewObjProc\fR( +\fITheCmdOldObjProc\fR( ClientData clientData, Tcl_Interp *interp, int objc, @@ -260,9 +187,6 @@ int } .CE .PP -The trampoline-enabled implementation requests postprocessing, -and returns to the trampoline requesting command evaluation. -.PP .CS int \fITheCmdNRObjProc\fR @@ -284,9 +208,6 @@ int } .CE .PP -The postprocessing procedure does whatever the original command did -upon return from the inner evaluation. -.PP .CS int \fITheCmdNRPostProc\fR( @@ -303,26 +224,13 @@ int } .CE .PP -If \fItheCommand\fR is a command that results in multiple commands or -scripts being evaluated, its postprocessing routine may schedule -additional postprocessing and then request another command evaluation -by means of \fBTcl_NREvalObj\fR or one of the other evaluation -routines. Looping and sequencing constructs may be implemented in this way. -.PP -Finally, to install a trampoline-enabled command in the interpreter, -\fBTcl_NRCreateCommand\fR is used in place of -\fBTcl_CreateObjCommand\fR. It accepts two command procedures instead -of one. The first is for use when no trampoline is yet on the stack, -and the second is for use when there is already a trampoline in place. +Any function comprising a routine can push other functions, making it possible +implement looping and sequencing constructs using the function stack. .PP -.CS -\fBTcl_NRCreateCommand\fR(interp, "theCommand", - \fITheCmdNewObjProc\fR, \fITheCmdNRObjProc\fR, clientData, - TheCmdDeleteProc); -.CE .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3) .SH KEYWORDS stackless, nonrecursive, execute, command, global, value, result, script .SH COPYRIGHT -Copyright (c) 2008 by Kevin B. Kenny +Copyright (c) 2008 by Kevin B. Kenny. +Copyright (c) 2018 by Nathan Coulter. -- cgit v0.12 From ad022e6d3b0857ae1266961eb07a1c3459d6e1cf Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 11 Feb 2018 19:29:08 +0000 Subject: Remove restriction on defining the class of a TclOO object not explicitly instantiated from ::oo::class. --- generic/tclOODefineCmds.c | 15 --------------- tests/oo.test | 4 ++-- 2 files changed, 2 insertions(+), 17 deletions(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index e953dc0..47b34bb 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1077,7 +1077,6 @@ TclOODefineClassObjCmd( { Object *oPtr; Class *clsPtr; - Foundation *fPtr = TclOOGetFoundation(interp); /* * Parse the context to get the object to operate on. @@ -1114,20 +1113,6 @@ TclOODefineClassObjCmd( return TCL_ERROR; } - /* - * Apply semantic checks. In particular, classes and non-classes are not - * interchangable (too complicated to do the conversion!) so we must - * produce an error if any attempt is made to swap from one to the other. - */ - - if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "may not change a %sclass object into a %sclass object", - (oPtr->classPtr==NULL ? "non-" : ""), - (oPtr->classPtr==NULL ? "" : "non-"))); - Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL); - return TCL_ERROR; - } /* * Set the object's class. diff --git a/tests/oo.test b/tests/oo.test index 61a5e01..8850ea5 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1668,13 +1668,13 @@ test oo-13.2 {OO: changing an object's class} -body { oo::objdefine foo class oo::class } -cleanup { foo destroy -} -returnCodes 1 -result {may not change a non-class object into a class object} +} -result {} test oo-13.3 {OO: changing an object's class} -body { oo::class create foo oo::objdefine foo class oo::object } -cleanup { foo destroy -} -returnCodes 1 -result {may not change a class object into a non-class object} +} -result {} test oo-13.4 {OO: changing an object's class} -body { oo::class create foo { method m {} { -- cgit v0.12 From 568724e4687c000b9ec9e66512048d5c8d8174f7 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 11 Feb 2018 19:35:27 +0000 Subject: Change the signature of PkgRequireCore in preparation to provide TclNRPackageObjCmd. --- generic/tclPkg.c | 43 +++++++++++++++++++++---------------------- 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 6d826a9..6a246bb 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -69,7 +69,7 @@ static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); -static const char * PkgRequireCore(Tcl_Interp *interp, const char *name, +static int PkgRequireCore(Tcl_Interp *interp, const char *name, int reqc, Tcl_Obj *const reqv[], void *clientDataPtr); @@ -299,7 +299,10 @@ Tcl_PkgRequireEx( */ if (version == NULL) { - result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr); + if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) { + result = Tcl_GetStringResult(interp); + Tcl_ResetResult(interp); + } } else { if (exact && TCL_OK != CheckVersionAndConvert(interp, version, NULL, NULL)) { @@ -310,10 +313,12 @@ Tcl_PkgRequireEx( Tcl_AppendStringsToObj(ov, "-", version, NULL); } Tcl_IncrRefCount(ov); - result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr); + if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) { + result = Tcl_GetStringResult(interp); + Tcl_ResetResult(interp); + } TclDecrRefCount(ov); } - return result; } @@ -328,17 +333,14 @@ Tcl_PkgRequireProc( * available. */ void *clientDataPtr) { - const char *result = - PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); - - if (result == NULL) { - return TCL_ERROR; + int code = CheckAllRequirements(interp, reqc, reqv); + if (code != TCL_OK) { + return code; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); - return TCL_OK; + return PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); } -static const char * +int PkgRequireCore( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ @@ -358,10 +360,6 @@ PkgRequireCore( char *script, *pkgVersionI; Tcl_DString command; - if (TCL_OK != CheckAllRequirements(interp, reqc, reqv)) { - return NULL; - } - /* * It can take up to three passes to find the package: one pass to run the * "package unknown" script, one to run the "package ifneeded" script for @@ -387,7 +385,7 @@ PkgRequireCore( name, (char *) pkgPtr->clientData, name)); AddRequirementsToResult(interp, reqc, reqv); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); - return NULL; + return TCL_ERROR; } /* @@ -598,7 +596,7 @@ PkgRequireCore( pkgPtr->version = NULL; } pkgPtr->clientData = NULL; - return NULL; + return code; } break; @@ -634,7 +632,7 @@ PkgRequireCore( if (code == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)"); - return NULL; + return code; } Tcl_ResetResult(interp); } @@ -645,7 +643,7 @@ PkgRequireCore( "can't find package %s", name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); AddRequirementsToResult(interp, reqc, reqv); - return NULL; + return TCL_ERROR; } /* @@ -666,7 +664,7 @@ PkgRequireCore( Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); AddRequirementsToResult(interp, reqc, reqv); - return NULL; + return TCL_ERROR; } } @@ -675,7 +673,8 @@ PkgRequireCore( *ptr = pkgPtr->clientData; } - return pkgPtr->version; + Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1)); + return TCL_OK; } /* -- cgit v0.12 From 4c79bcbe64fca55bf859f1fb9a78bf887d7c78dc Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 12 Feb 2018 10:14:02 +0000 Subject: Preparation to provide TclNRPackageObjectCmd: Eliminate the loop in PkgRequireCore so that TclNRAddCallback can be added at the needed spots. --- generic/tclInt.h | 1 + generic/tclPkg.c | 525 ++++++++++++++++++++++++++++--------------------------- 2 files changed, 264 insertions(+), 262 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 4967cd3..ac67ebd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2750,6 +2750,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRPackageObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 6a246bb..b48e71b 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -72,6 +72,8 @@ static Package * FindPackage(Tcl_Interp *interp, const char *name); static int PkgRequireCore(Tcl_Interp *interp, const char *name, int reqc, Tcl_Obj *const reqv[], void *clientDataPtr); +static int SelectPackage (Tcl_Interp *interp, const char *name, + Package *pkgPtr, int reqc, Tcl_Obj *const reqv[]); /* * Helper macros. @@ -351,329 +353,328 @@ PkgRequireCore( * available. */ void *clientDataPtr) { - Interp *iPtr = (Interp *) interp; Package *pkgPtr; - PkgAvail *availPtr, *bestPtr, *bestStablePtr; - char *availVersion, *bestVersion, *bestStableVersion; - /* Internal rep. of versions */ - int availStable, code, satisfies, pass; + int code, satisfies; char *script, *pkgVersionI; Tcl_DString command; + pkgPtr = FindPackage(interp, name); + if (pkgPtr->version == NULL) { + code = SelectPackage(interp, name, pkgPtr, reqc, reqv); + if (code != TCL_OK) { + return code; + } + if (pkgPtr->version == NULL) { + /* + * The package is not in the database. If there is a "package unknown" + * command, invoke it. + */ + + script = ((Interp *) interp)->packageUnknown; + if (script != NULL) { + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + AddRequirementsToDString(&command, reqc, reqv); + + code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), + Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); + Tcl_DStringFree(&command); + + if ((code != TCL_OK) && (code != TCL_ERROR)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad return code: %d", code)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + code = TCL_ERROR; + } + if (code == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package unknown\" script)"); + return code; + } + Tcl_ResetResult(interp); + } + /* pkgPtr may now be invalid, so refresh it. */ + pkgPtr = FindPackage(interp, name); + code = SelectPackage(interp, name, pkgPtr, reqc, reqv); + if (code != TCL_OK) { + return code; + } + } + } + + if (pkgPtr->version == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't find package %s", name)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); + AddRequirementsToResult(interp, reqc, reqv); + return TCL_ERROR; + } + /* - * It can take up to three passes to find the package: one pass to run the - * "package unknown" script, one to run the "package ifneeded" script for - * a specific version, and a final pass to lookup the package loaded by - * the "package ifneeded" script. + * Ensure that the provided version meets the current requirements. */ - for (pass=1 ;; pass++) { - pkgPtr = FindPackage(interp, name); - if (pkgPtr->version != NULL) { - break; - } + if (reqc != 0) { + CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); + satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); - /* - * Check whether we're already attempting to load some version of this - * package (circular dependency detection). - */ + ckfree(pkgVersionI); - if (pkgPtr->clientData != NULL) { + if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "circular package dependency:" - " attempt to provide %s %s requires %s", - name, (char *) pkgPtr->clientData, name)); + "version conflict for package \"%s\": have %s, need", + name, pkgPtr->version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", + NULL); AddRequirementsToResult(interp, reqc, reqv); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); return TCL_ERROR; } + } - /* - * The package isn't yet present. Search the list of available - * versions and invoke the script for the best available version. We - * are actually locating the best, and the best stable version. One of - * them is then chosen based on the selection mode. - */ - - bestPtr = NULL; - bestStablePtr = NULL; - bestVersion = NULL; - bestStableVersion = NULL; + if (clientDataPtr) { + const void **ptr = (const void **) clientDataPtr; - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - if (CheckVersionAndConvert(interp, availPtr->version, - &availVersion, &availStable) != TCL_OK) { - /* - * The provided version number has invalid syntax. This - * should not happen. This should have been caught by the - * 'package ifneeded' registering the package. - */ + *ptr = pkgPtr->clientData; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1)); + return TCL_OK; +} + +int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int reqc, Tcl_Obj *const reqv[]) { + PkgAvail *availPtr, *bestPtr, *bestStablePtr; + char *availVersion, *bestVersion, *bestStableVersion; + /* Internal rep. of versions */ + char *script; + int availStable, code, satisfies; + Interp *iPtr = (Interp *) interp; - continue; - } + /* + * Check whether we're already attempting to load some version of this + * package (circular dependency detection). + */ - /* Check satisfaction of requirements before considering the current version further. */ - if (reqc > 0) { - satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); - if (!satisfies) { - ckfree(availVersion); - availVersion = NULL; - continue; - } - } + if (pkgPtr->clientData != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "circular package dependency:" + " attempt to provide %s %s requires %s", + name, (char *) pkgPtr->clientData, name)); + AddRequirementsToResult(interp, reqc, reqv); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); + return TCL_ERROR; + } - if (bestPtr != NULL) { - int res = CompareVersions(availVersion, bestVersion, NULL); + /* + * The package isn't yet present. Search the list of available + * versions and invoke the script for the best available version. We + * are actually locating the best, and the best stable version. One of + * them is then chosen based on the selection mode. + */ - /* - * Note: Used internal reps in the comparison! - */ + bestPtr = NULL; + bestStablePtr = NULL; + bestVersion = NULL; + bestStableVersion = NULL; - if (res > 0) { - /* - * The version of the package sought is better than the - * currently selected version. - */ - ckfree(bestVersion); - bestVersion = NULL; - goto newbest; - } - } else { - newbest: - /* We have found a version which is better than our max. */ + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + if (CheckVersionAndConvert(interp, availPtr->version, + &availVersion, &availStable) != TCL_OK) { + /* + * The provided version number has invalid syntax. This + * should not happen. This should have been caught by the + * 'package ifneeded' registering the package. + */ - bestPtr = availPtr; - CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); - } + continue; + } - if (!availStable) { + /* Check satisfaction of requirements before considering the current version further. */ + if (reqc > 0) { + satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); + if (!satisfies) { ckfree(availVersion); availVersion = NULL; continue; } + } - if (bestStablePtr != NULL) { - int res = CompareVersions(availVersion, bestStableVersion, NULL); + if (bestPtr != NULL) { + int res = CompareVersions(availVersion, bestVersion, NULL); + + /* + * Note: Used internal reps in the comparison! + */ + if (res > 0) { /* - * Note: Used internal reps in the comparison! + * The version of the package sought is better than the + * currently selected version. */ - - if (res > 0) { - /* - * This stable version of the package sought is better - * than the currently selected stable version. - */ - ckfree(bestStableVersion); - bestStableVersion = NULL; - goto newstable; - } - } else { - newstable: - /* We have found a stable version which is better than our max stable. */ - bestStablePtr = availPtr; - CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); + ckfree(bestVersion); + bestVersion = NULL; + goto newbest; } + } else { + newbest: + /* We have found a version which is better than our max. */ - ckfree(availVersion); - availVersion = NULL; - } /* end for */ - - /* - * Clean up memorized internal reps, if any. - */ - - if (bestVersion != NULL) { - ckfree(bestVersion); - bestVersion = NULL; + bestPtr = availPtr; + CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); } - if (bestStableVersion != NULL) { - ckfree(bestStableVersion); - bestStableVersion = NULL; + if (!availStable) { + ckfree(availVersion); + availVersion = NULL; + continue; } - /* - * Now choose a version among the two best. For 'latest' we simply - * take (actually keep) the best. For 'stable' we take the best - * stable, if there is any, or the best if there is nothing stable. - */ + if (bestStablePtr != NULL) { + int res = CompareVersions(availVersion, bestStableVersion, NULL); - if ((iPtr->packagePrefer == PKG_PREFER_STABLE) - && (bestStablePtr != NULL)) { - bestPtr = bestStablePtr; - } - - if (bestPtr != NULL) { /* - * We found an ifneeded script for the package. Be careful while - * executing it: this could cause reentrancy, so (a) protect the - * script itself from deletion and (b) don't assume that bestPtr - * will still exist when the script completes. + * Note: Used internal reps in the comparison! */ - char *versionToProvide = bestPtr->version; - script = bestPtr->script; - - pkgPtr->clientData = versionToProvide; - Tcl_Preserve(script); - Tcl_Preserve(versionToProvide); - code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); - Tcl_Release(script); - - pkgPtr = FindPackage(interp, name); - if (code == TCL_OK) { - Tcl_ResetResult(interp); - if (pkgPtr->version == NULL) { - code = TCL_ERROR; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " no version of package %s provided", - name, versionToProvide, name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", - NULL); - } else { - char *pvi, *vi; - - if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, - NULL) != TCL_OK) { - code = TCL_ERROR; - } else if (CheckVersionAndConvert(interp, - versionToProvide, &vi, NULL) != TCL_OK) { - ckfree(pvi); - code = TCL_ERROR; - } else { - int res = CompareVersions(pvi, vi, NULL); - - ckfree(pvi); - ckfree(vi); - if (res != 0) { - code = TCL_ERROR; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " package %s %s provided instead", - name, versionToProvide, - name, pkgPtr->version)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", - "WRONGPROVIDE", NULL); - } - } - } - } else if (code != TCL_ERROR) { - Tcl_Obj *codePtr = Tcl_NewIntObj(code); - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " bad return code: %s", - name, versionToProvide, TclGetString(codePtr))); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - TclDecrRefCount(codePtr); - code = TCL_ERROR; - } - - if (code == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"package ifneeded %s %s\" script)", - name, versionToProvide)); - } - Tcl_Release(versionToProvide); - - if (code != TCL_OK) { + if (res > 0) { /* - * Take a non-TCL_OK code from the script as an indication the - * package wasn't loaded properly, so the package system - * should not remember an improper load. - * - * This is consistent with our returning NULL. If we're not - * willing to tell our caller we got a particular version, we - * shouldn't store that version for telling future callers - * either. + * This stable version of the package sought is better + * than the currently selected stable version. */ - - if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); - pkgPtr->version = NULL; - } - pkgPtr->clientData = NULL; - return code; + ckfree(bestStableVersion); + bestStableVersion = NULL; + goto newstable; } - - break; - } - - /* - * The package is not in the database. If there is a "package unknown" - * command, invoke it (but only on the first pass; after that, we - * should not get here in the first place). - */ - - if (pass > 1) { - break; + } else { + newstable: + /* We have found a stable version which is better than our max stable. */ + bestStablePtr = availPtr; + CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); } - script = ((Interp *) interp)->packageUnknown; - if (script != NULL) { - Tcl_DStringInit(&command); - Tcl_DStringAppend(&command, script, -1); - Tcl_DStringAppendElement(&command, name); - AddRequirementsToDString(&command, reqc, reqv); + ckfree(availVersion); + availVersion = NULL; + } /* end for */ - code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), - Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); - Tcl_DStringFree(&command); + /* + * Clean up memorized internal reps, if any. + */ - if ((code != TCL_OK) && (code != TCL_ERROR)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad return code: %d", code)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - code = TCL_ERROR; - } - if (code == TCL_ERROR) { - Tcl_AddErrorInfo(interp, - "\n (\"package unknown\" script)"); - return code; - } - Tcl_ResetResult(interp); - } + if (bestVersion != NULL) { + ckfree(bestVersion); + bestVersion = NULL; } - if (pkgPtr->version == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't find package %s", name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); - AddRequirementsToResult(interp, reqc, reqv); - return TCL_ERROR; + if (bestStableVersion != NULL) { + ckfree(bestStableVersion); + bestStableVersion = NULL; } /* - * At this point we know that the package is present. Make sure that the - * provided version meets the current requirements. + * Now choose a version among the two best. For 'latest' we simply + * take (actually keep) the best. For 'stable' we take the best + * stable, if there is any, or the best if there is nothing stable. */ - if (reqc != 0) { - CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); - satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); + if ((iPtr->packagePrefer == PKG_PREFER_STABLE) + && (bestStablePtr != NULL)) { + bestPtr = bestStablePtr; + } - ckfree(pkgVersionI); + if (bestPtr != NULL) { + /* + * We found an ifneeded script for the package. Be careful while + * executing it: this could cause reentrancy, so (a) protect the + * script itself from deletion and (b) don't assume that bestPtr + * will still exist when the script completes. + */ + + char *versionToProvide = bestPtr->version; + script = bestPtr->script; + + pkgPtr->clientData = versionToProvide; + Tcl_Preserve(script); + Tcl_Preserve(versionToProvide); + code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); + Tcl_Release(script); + + pkgPtr = FindPackage(interp, name); + if (code == TCL_OK) { + Tcl_ResetResult(interp); + if (pkgPtr->version == NULL) { + code = TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " no version of package %s provided", + name, versionToProvide, name)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", + NULL); + } else { + char *pvi, *vi; + + if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, + NULL) != TCL_OK) { + code = TCL_ERROR; + } else if (CheckVersionAndConvert(interp, + versionToProvide, &vi, NULL) != TCL_OK) { + ckfree(pvi); + code = TCL_ERROR; + } else { + int res = CompareVersions(pvi, vi, NULL); + + ckfree(pvi); + ckfree(vi); + if (res != 0) { + code = TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " package %s %s provided instead", + name, versionToProvide, + name, pkgPtr->version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", + "WRONGPROVIDE", NULL); + } + } + } + } else if (code != TCL_ERROR) { + Tcl_Obj *codePtr = Tcl_NewIntObj(code); - if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "version conflict for package \"%s\": have %s, need", - name, pkgPtr->version)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", - NULL); - AddRequirementsToResult(interp, reqc, reqv); - return TCL_ERROR; + "attempt to provide package %s %s failed:" + " bad return code: %s", + name, versionToProvide, TclGetString(codePtr))); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + TclDecrRefCount(codePtr); + code = TCL_ERROR; } - } - if (clientDataPtr) { - const void **ptr = (const void **) clientDataPtr; + if (code == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"package ifneeded %s %s\" script)", + name, versionToProvide)); + } + Tcl_Release(versionToProvide); - *ptr = pkgPtr->clientData; + if (code != TCL_OK) { + /* + * Take a non-TCL_OK code from the script as an indication the + * package wasn't loaded properly, so the package system + * should not remember an improper load. + * + * This is consistent with our returning NULL. If we're not + * willing to tell our caller we got a particular version, we + * shouldn't store that version for telling future callers + * either. + */ + + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + pkgPtr->version = NULL; + } + pkgPtr->clientData = NULL; + return code; + } } - Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1)); return TCL_OK; } -- cgit v0.12 From f4babdb0acc66d9d4eda61a094f12f99a24b8915 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 12 Feb 2018 10:44:44 +0000 Subject: Adapt signature of PkgRequireCore to conform to Tcl_ObjCmdProc, and call it in Tcl_PkgRequireProc on an NRE trampoline via Tcl_NRCallObjProc. Additional callbacks still needed to fully NRE-enable [package require]. --- generic/tclPkg.c | 83 ++++++++++++++++++++++++++++++++------------------------ 1 file changed, 48 insertions(+), 35 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index b48e71b..ff8db13 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -49,6 +49,12 @@ typedef struct Package { const void *clientData; /* Client data. */ } Package; +typedef struct Require { + void * clientDataPtr; + const char *name; + Package *pkgPtr; +} Require; + /* * Prototypes for functions defined in this file: */ @@ -69,11 +75,10 @@ static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); -static int PkgRequireCore(Tcl_Interp *interp, const char *name, - int reqc, Tcl_Obj *const reqv[], - void *clientDataPtr); -static int SelectPackage (Tcl_Interp *interp, const char *name, - Package *pkgPtr, int reqc, Tcl_Obj *const reqv[]); +static int PkgRequireCore(ClientData clientData, Tcl_Interp *interp, + int reqc, Tcl_Obj *const reqv[]); +static int SelectPackage (Tcl_Interp *interp, Require *reqPtr, + int reqc, Tcl_Obj *const reqv[]); /* * Helper macros. @@ -336,35 +341,41 @@ Tcl_PkgRequireProc( void *clientDataPtr) { int code = CheckAllRequirements(interp, reqc, reqv); + Require require; if (code != TCL_OK) { return code; } - return PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); + require.clientDataPtr = clientDataPtr; + require.name = name; + require.pkgPtr = NULL; + return Tcl_NRCallObjProc(interp, PkgRequireCore, &require, reqc, reqv); } int PkgRequireCore( + ClientData clientData, Tcl_Interp *interp, /* Interpreter in which package is now * available. */ - const char *name, /* Name of desired package. */ int reqc, /* Requirements constraining the desired * version. */ - Tcl_Obj *const reqv[], /* 0 means to use the latest version + Tcl_Obj *const reqv[] /* 0 means to use the latest version * available. */ - void *clientDataPtr) + ) { - Package *pkgPtr; int code, satisfies; - char *script, *pkgVersionI; Tcl_DString command; + Require *reqPtr = clientData; + char *script, *pkgVersionI; + const char *name = reqPtr->name /* Name of desired package. */; + void *clientDataPtr = reqPtr->clientDataPtr; - pkgPtr = FindPackage(interp, name); - if (pkgPtr->version == NULL) { - code = SelectPackage(interp, name, pkgPtr, reqc, reqv); + reqPtr->pkgPtr = FindPackage(interp, name); + if (reqPtr->pkgPtr->version == NULL) { + code = SelectPackage(interp, reqPtr, reqc, reqv); if (code != TCL_OK) { return code; } - if (pkgPtr->version == NULL) { + if (reqPtr->pkgPtr->version == NULL) { /* * The package is not in the database. If there is a "package unknown" * command, invoke it. @@ -393,17 +404,17 @@ PkgRequireCore( return code; } Tcl_ResetResult(interp); - } - /* pkgPtr may now be invalid, so refresh it. */ - pkgPtr = FindPackage(interp, name); - code = SelectPackage(interp, name, pkgPtr, reqc, reqv); - if (code != TCL_OK) { - return code; + /* pkgPtr may now be invalid, so refresh it. */ + reqPtr->pkgPtr = FindPackage(interp, name); + code = SelectPackage(interp, reqPtr, reqc, reqv); + if (code != TCL_OK) { + return code; + } } } } - if (pkgPtr->version == NULL) { + if (reqPtr->pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't find package %s", name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); @@ -416,7 +427,7 @@ PkgRequireCore( */ if (reqc != 0) { - CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); + CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pkgVersionI, NULL); satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); ckfree(pkgVersionI); @@ -424,7 +435,7 @@ PkgRequireCore( if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "version conflict for package \"%s\": have %s, need", - name, pkgPtr->version)); + name, reqPtr->pkgPtr->version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); AddRequirementsToResult(interp, reqc, reqv); @@ -435,18 +446,20 @@ PkgRequireCore( if (clientDataPtr) { const void **ptr = (const void **) clientDataPtr; - *ptr = pkgPtr->clientData; + *ptr = reqPtr->pkgPtr->clientData; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1)); return TCL_OK; } -int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int reqc, Tcl_Obj *const reqv[]) { +int SelectPackage (Tcl_Interp *interp, Require *reqPtr, int reqc, Tcl_Obj *const reqv[]) { PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ char *script; int availStable, code, satisfies; + const char *name = reqPtr->name; + Package *pkgPtr = reqPtr->pkgPtr; Interp *iPtr = (Interp *) interp; /* @@ -598,10 +611,10 @@ int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int re code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); Tcl_Release(script); - pkgPtr = FindPackage(interp, name); + reqPtr->pkgPtr = FindPackage(interp, name); if (code == TCL_OK) { Tcl_ResetResult(interp); - if (pkgPtr->version == NULL) { + if (reqPtr->pkgPtr->version == NULL) { code = TCL_ERROR; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to provide package %s %s failed:" @@ -612,7 +625,7 @@ int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int re } else { char *pvi, *vi; - if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, + if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi, NULL) != TCL_OK) { code = TCL_ERROR; } else if (CheckVersionAndConvert(interp, @@ -630,7 +643,7 @@ int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int re "attempt to provide package %s %s failed:" " package %s %s provided instead", name, versionToProvide, - name, pkgPtr->version)); + name, reqPtr->pkgPtr->version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "WRONGPROVIDE", NULL); } @@ -667,11 +680,11 @@ int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int re * either. */ - if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); - pkgPtr->version = NULL; + if (reqPtr->pkgPtr->version != NULL) { + ckfree(reqPtr->pkgPtr->version); + reqPtr->pkgPtr->version = NULL; } - pkgPtr->clientData = NULL; + reqPtr->pkgPtr->clientData = NULL; return code; } } -- cgit v0.12 From 1553090bc312c0691df9549983c1d25542c16ef5 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 12 Feb 2018 12:40:34 +0000 Subject: Add remaining wrapper to the NR functions, remaining calls to TCL_NRAddCallback, and a test for a package require script that yields. DGP: This checkin introduces a memleak, detected by test compExpr-7.1. --- generic/tclBasic.c | 4 +- generic/tclPkg.c | 408 +++++++++++++++++++++++++++++++++-------------------- tests/package.test | 12 ++ 3 files changed, 273 insertions(+), 151 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index ddc828a..e2319d2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -234,7 +234,7 @@ static const CmdInfo builtInCmds[] = { {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"package", Tcl_PackageObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE}, {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE}, @@ -4428,6 +4428,8 @@ TclNRRunCallbacks( (void) Tcl_GetObjResult(interp); } + /* This is the trampoline. */ + while (TOP_CB(interp) != rootPtr) { callbackPtr = TOP_CB(interp); procPtr = callbackPtr->procPtr; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index ff8db13..e956a40 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -53,8 +53,14 @@ typedef struct Require { void * clientDataPtr; const char *name; Package *pkgPtr; + char *versionToProvide; } Require; +typedef struct RequireProcArgs { + const char *name; + void *clientDataPtr; +} RequireProcArgs; + /* * Prototypes for functions defined in this file: */ @@ -75,10 +81,15 @@ static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); -static int PkgRequireCore(ClientData clientData, Tcl_Interp *interp, - int reqc, Tcl_Obj *const reqv[]); -static int SelectPackage (Tcl_Interp *interp, Require *reqPtr, - int reqc, Tcl_Obj *const reqv[]); +static int PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result); +static int TclNRPkgRequireProc(ClientData clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); +static int SelectPackage(ClientData data[], Tcl_Interp *interp, int result); +static int SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result); +static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result); /* * Helper macros. @@ -340,80 +351,116 @@ Tcl_PkgRequireProc( * available. */ void *clientDataPtr) { + RequireProcArgs args; + args.name = name; + args.clientDataPtr = clientDataPtr; + return Tcl_NRCallObjProc(interp, TclNRPkgRequireProc, (void *)&args, reqc, reqv); +} + +static int +TclNRPkgRequireProc( + ClientData clientData, + Tcl_Interp *interp, + int reqc, + Tcl_Obj *const reqv[]) { + RequireProcArgs *args = clientData; + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)args->name, INT2PTR(reqc), (void *)reqv, args->clientDataPtr); + return TCL_OK; +} + +static int +PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result) +{ + const char *name = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj *const *reqv = data[2]; int code = CheckAllRequirements(interp, reqc, reqv); - Require require; + Require *reqPtr; if (code != TCL_OK) { return code; } - require.clientDataPtr = clientDataPtr; - require.name = name; - require.pkgPtr = NULL; - return Tcl_NRCallObjProc(interp, PkgRequireCore, &require, reqc, reqv); + reqPtr = ckalloc(sizeof(Require)); + Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL); + reqPtr->clientDataPtr = data[3]; + reqPtr->name = name; + reqPtr->pkgPtr = FindPackage(interp, name); + if (reqPtr->pkgPtr->version == NULL) { + Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreStep1); + } else { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } + return TCL_OK; } -int -PkgRequireCore( - ClientData clientData, - Tcl_Interp *interp, /* Interpreter in which package is now - * available. */ - int reqc, /* Requirements constraining the desired - * version. */ - Tcl_Obj *const reqv[] /* 0 means to use the latest version - * available. */ - ) -{ - int code, satisfies; +static int +PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) { Tcl_DString command; - Require *reqPtr = clientData; - char *script, *pkgVersionI; + char *script; + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name /* Name of desired package. */; - void *clientDataPtr = reqPtr->clientDataPtr; - - reqPtr->pkgPtr = FindPackage(interp, name); if (reqPtr->pkgPtr->version == NULL) { - code = SelectPackage(interp, reqPtr, reqc, reqv); - if (code != TCL_OK) { - return code; - } - if (reqPtr->pkgPtr->version == NULL) { - /* - * The package is not in the database. If there is a "package unknown" - * command, invoke it. - */ + /* + * The package is not in the database. If there is a "package unknown" + * command, invoke it. + */ - script = ((Interp *) interp)->packageUnknown; - if (script != NULL) { - Tcl_DStringInit(&command); - Tcl_DStringAppend(&command, script, -1); - Tcl_DStringAppendElement(&command, name); - AddRequirementsToDString(&command, reqc, reqv); - - code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), - Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); - Tcl_DStringFree(&command); - - if ((code != TCL_OK) && (code != TCL_ERROR)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad return code: %d", code)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - code = TCL_ERROR; - } - if (code == TCL_ERROR) { - Tcl_AddErrorInfo(interp, - "\n (\"package unknown\" script)"); - return code; - } - Tcl_ResetResult(interp); - /* pkgPtr may now be invalid, so refresh it. */ - reqPtr->pkgPtr = FindPackage(interp, name); - code = SelectPackage(interp, reqPtr, reqc, reqv); - if (code != TCL_OK) { - return code; - } - } - } + script = ((Interp *) interp)->packageUnknown; + if (script == NULL) { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } else { + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + AddRequirementsToDString(&command, reqc, reqv); + + Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NREvalObj(interp, + Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)), + TCL_EVAL_GLOBAL + ); + Tcl_DStringFree(&command); + } + return TCL_OK; + } else { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } + return TCL_OK; +} + +static int +PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) { + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; + const char *name = reqPtr->name /* Name of desired package. */; + if ((result != TCL_OK) && (result != TCL_ERROR)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad return code: %d", result)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + result = TCL_ERROR; } + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package unknown\" script)"); + return result; + } + Tcl_ResetResult(interp); + /* pkgPtr may now be invalid, so refresh it. */ + reqPtr->pkgPtr = FindPackage(interp, name); + Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreFinal); + return TCL_OK; +} +static int +PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]), satisfies; + Tcl_Obj **const reqv = data[2]; + char *pkgVersionI; + void *clientDataPtr = reqPtr->clientDataPtr; + const char *name = reqPtr->name /* Name of desired package. */; if (reqPtr->pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't find package %s", name)); @@ -451,13 +498,23 @@ PkgRequireCore( Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1)); return TCL_OK; } + +static int +PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) { + ckfree(data[0]); + return result; +} + -int SelectPackage (Tcl_Interp *interp, Require *reqPtr, int reqc, Tcl_Obj *const reqv[]) { +static int +SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ - char *script; - int availStable, code, satisfies; + int availStable, satisfies; + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name; Package *pkgPtr = reqPtr->pkgPtr; Interp *iPtr = (Interp *) interp; @@ -594,7 +651,9 @@ int SelectPackage (Tcl_Interp *interp, Require *reqPtr, int reqc, Tcl_Obj *const bestPtr = bestStablePtr; } - if (bestPtr != NULL) { + if (bestPtr == NULL) { + Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } else { /* * We found an ifneeded script for the package. Be careful while * executing it: this could cause reentrancy, so (a) protect the @@ -603,91 +662,102 @@ int SelectPackage (Tcl_Interp *interp, Require *reqPtr, int reqc, Tcl_Obj *const */ char *versionToProvide = bestPtr->version; - script = bestPtr->script; pkgPtr->clientData = versionToProvide; - Tcl_Preserve(script); Tcl_Preserve(versionToProvide); - code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); - Tcl_Release(script); + reqPtr->versionToProvide = versionToProvide; + Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]); + Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL); + } + return TCL_OK; +} + +static int +SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; + const char *name = reqPtr->name; + char *versionToProvide = reqPtr->versionToProvide; - reqPtr->pkgPtr = FindPackage(interp, name); - if (code == TCL_OK) { - Tcl_ResetResult(interp); - if (reqPtr->pkgPtr->version == NULL) { - code = TCL_ERROR; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " no version of package %s provided", - name, versionToProvide, name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", - NULL); + reqPtr->pkgPtr = FindPackage(interp, name); + if (result == TCL_OK) { + Tcl_ResetResult(interp); + if (reqPtr->pkgPtr->version == NULL) { + result = TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " no version of package %s provided", + name, versionToProvide, name)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", + NULL); + } else { + char *pvi, *vi; + + if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi, + NULL) != TCL_OK) { + result = TCL_ERROR; + } else if (CheckVersionAndConvert(interp, + versionToProvide, &vi, NULL) != TCL_OK) { + ckfree(pvi); + result = TCL_ERROR; } else { - char *pvi, *vi; - - if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi, - NULL) != TCL_OK) { - code = TCL_ERROR; - } else if (CheckVersionAndConvert(interp, - versionToProvide, &vi, NULL) != TCL_OK) { - ckfree(pvi); - code = TCL_ERROR; - } else { - int res = CompareVersions(pvi, vi, NULL); - - ckfree(pvi); - ckfree(vi); - if (res != 0) { - code = TCL_ERROR; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " package %s %s provided instead", - name, versionToProvide, - name, reqPtr->pkgPtr->version)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", - "WRONGPROVIDE", NULL); - } + int res = CompareVersions(pvi, vi, NULL); + + ckfree(pvi); + ckfree(vi); + if (res != 0) { + result = TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " package %s %s provided instead", + name, versionToProvide, + name, reqPtr->pkgPtr->version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", + "WRONGPROVIDE", NULL); } } - } else if (code != TCL_ERROR) { - Tcl_Obj *codePtr = Tcl_NewIntObj(code); - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " bad return code: %s", - name, versionToProvide, TclGetString(codePtr))); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - TclDecrRefCount(codePtr); - code = TCL_ERROR; } + } else if (result != TCL_ERROR) { + Tcl_Obj *codePtr = Tcl_NewIntObj(result); - if (code == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"package ifneeded %s %s\" script)", - name, versionToProvide)); - } - Tcl_Release(versionToProvide); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " bad return code: %s", + name, versionToProvide, TclGetString(codePtr))); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + TclDecrRefCount(codePtr); + result = TCL_ERROR; + } - if (code != TCL_OK) { - /* - * Take a non-TCL_OK code from the script as an indication the - * package wasn't loaded properly, so the package system - * should not remember an improper load. - * - * This is consistent with our returning NULL. If we're not - * willing to tell our caller we got a particular version, we - * shouldn't store that version for telling future callers - * either. - */ + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"package ifneeded %s %s\" script)", + name, versionToProvide)); + } + Tcl_Release(versionToProvide); - if (reqPtr->pkgPtr->version != NULL) { - ckfree(reqPtr->pkgPtr->version); - reqPtr->pkgPtr->version = NULL; - } - reqPtr->pkgPtr->clientData = NULL; - return code; + if (result != TCL_OK) { + /* + * Take a non-TCL_OK code from the script as an indication the + * package wasn't loaded properly, so the package system + * should not remember an improper load. + * + * This is consistent with our returning NULL. If we're not + * willing to tell our caller we got a particular version, we + * shouldn't store that version for telling future callers + * either. + */ + + if (reqPtr->pkgPtr->version != NULL) { + ckfree(reqPtr->pkgPtr->version); + reqPtr->pkgPtr->version = NULL; } + reqPtr->pkgPtr->clientData = NULL; + return result; } + + Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); return TCL_OK; } @@ -794,10 +864,19 @@ Tcl_PkgPresentEx( * *---------------------------------------------------------------------- */ +int +Tcl_PackageObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, NULL, objc, objv); +} /* ARGSUSED */ int -Tcl_PackageObjCmd( +TclNRPackageObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -814,7 +893,7 @@ Tcl_PackageObjCmd( PKG_VSATISFIES }; Interp *iPtr = (Interp *) interp; - int optionIndex, exact, i, satisfies; + int optionIndex, exact, i, newobjc, satisfies; PkgAvail *availPtr, *prevPtr; Package *pkgPtr; Tcl_HashEntry *hPtr; @@ -823,6 +902,7 @@ Tcl_PackageObjCmd( const char *version; const char *argv2, *argv3, *argv4; char *iva = NULL, *ivb = NULL; + Tcl_Obj *objvListPtr, **newObjvPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); @@ -1029,7 +1109,6 @@ Tcl_PackageObjCmd( argv2 = TclGetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { Tcl_Obj *ov; - int res; if (objc != 5) { goto requireSyntax; @@ -1046,20 +1125,42 @@ Tcl_PackageObjCmd( */ ov = Tcl_NewStringObj(version, -1); + Tcl_IncrRefCount(ov); Tcl_AppendStringsToObj(ov, "-", version, NULL); version = NULL; argv3 = TclGetString(objv[3]); + Tcl_IncrRefCount(objv[3]); - Tcl_IncrRefCount(ov); - res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL); - TclDecrRefCount(ov); - return res; + objvListPtr = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(objvListPtr); + Tcl_ListObjAppendElement(interp, objvListPtr, ov); + Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + + Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL); + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL); + return TCL_OK; } else { + int i, newobjc = objc-3; + Tcl_Obj *const *newobjv = objv + 3; if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { return TCL_ERROR; } + objvListPtr = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(objvListPtr); + Tcl_IncrRefCount(objv[2]); + for (i = 0; i < newobjc; i++) { + + /* + * Tcl_Obj structures may have come from another interpreter, + * so duplicate them. + */ - return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL); + Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); + } + Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL); + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL); + return TCL_OK; } break; case PKG_UNKNOWN: { @@ -1199,6 +1300,13 @@ Tcl_PackageObjCmd( } return TCL_OK; } + +static int +TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result) { + TclDecrRefCount((Tcl_Obj *)data[0]); + TclDecrRefCount((Tcl_Obj *)data[1]); + return result; +} /* *---------------------------------------------------------------------- diff --git a/tests/package.test b/tests/package.test index 74415ae..bc73003 100644 --- a/tests/package.test +++ b/tests/package.test @@ -608,6 +608,18 @@ test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} { package require t set x } {1.1} +test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup { + package forget t +} -body { + coroutine coro1 apply {{} { + package ifneeded t 2.1 { + yield + package provide t 2.1 + } + package require t 2.1 + }} + list [catch {coro1} msg] $msg +} -match glob -result {0 2.1} test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body { -- cgit v0.12 From 396c1a637c399fdb78e0d52ec4944859fa072e5c Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 13 Feb 2018 20:51:57 +0000 Subject: New test expr-32.7 for bignum modulus range. --- tests/expr.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/expr.test b/tests/expr.test index 5843b49..c49a9ff 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -5838,6 +5838,9 @@ test expr-32.5 {Bug 1585704} { test expr-32.6 {Bug 1585704} { expr -(1<<32)%(1<<63) } [expr (1<<63)-(1<<32)] +test expr-32.7 {bignum regression} { + expr {0%(1<<63)} +} 0 test expr-33.1 {parse largest long value} longIs32bit { set max_long_str 2147483647 -- cgit v0.12 From 4a6163c6a6a7f6e85f28f753e303caaa99b83a31 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 13 Feb 2018 20:59:36 +0000 Subject: test expr-32.7 for bignum modulus range. FAILING for now. Error in TIP 484. --- tests/expr.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/expr.test b/tests/expr.test index 0b3620a..4fac8b1 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -5799,6 +5799,9 @@ test expr-32.5 {Bug 1585704} { test expr-32.6 {Bug 1585704} { expr -(1<<32)%(1<<63) } [expr (1<<63)-(1<<32)] +test expr-32.7 {bignum regression} { + expr {0%(1<<63)} +} 0 test expr-33.1 {parse largest long value} longIs32bit { set max_long_str 2147483647 -- cgit v0.12 From ea6e8c9dcdd3f2e3fa35a81646981e384593aae0 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 14 Feb 2018 10:46:08 +0000 Subject: Fix for issue 9fd5c629c1, TclOO - aborts when a trace on command deletion deletes the object's namespace. --- generic/tclBasic.c | 8 ++++---- generic/tclFileName.c | 2 +- generic/tclOO.c | 35 ++++++++++++++++++++++++++--------- generic/tclOOCall.c | 8 ++++---- generic/tclOOInt.h | 16 ++++++++-------- tests/oo.test | 12 ++++++++++++ 6 files changed, 55 insertions(+), 26 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e2319d2..9720689 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3100,7 +3100,7 @@ Tcl_DeleteCommandFromToken( /* * We must delete this command, even though both traces and delete procs * may try to avoid this (renaming the command etc). Also traces and - * delete procs may try to delete the command themsevles. This flag + * delete procs may try to delete the command themselves. This flag * declares that a delete is in progress and that recursive deletes should * be ignored. */ @@ -7704,8 +7704,8 @@ ExprRandFunc( iPtr->flags |= RAND_SEED_INITIALIZED; /* - * Take into consideration the thread this interp is running in order - * to insure different seeds in different threads (bug #416643) + * To ensure different seeds in different threads (bug #416643), + * take into consideration the thread this interp is running in. */ iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); @@ -9073,7 +9073,7 @@ TclNRCoroutineObjCmd( TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL); - /* insure that the command is looked up in the correct namespace */ + /* ensure that the command is looked up in the correct namespace */ iPtr->lookupNsPtr = lookupNsPtr; Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); iPtr->numLevels--; diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 2136883..b566d7f 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1904,7 +1904,7 @@ TclGlob( } /* - * To process a [glob] invokation, this function may be called multiple + * To process a [glob] invocation, this function may be called multiple * times. Each time, the previously discovered filenames are in the * interpreter result. We stash that away here so the result is free for * error messsages. diff --git a/generic/tclOO.c b/generic/tclOO.c index f236ac9..bae784a 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -880,7 +880,7 @@ ObjectRenamedTrace( * 2950259] */ - if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) { + if (oPtr->namespacePtr && ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) { Tcl_DeleteNamespace(oPtr->namespacePtr); } if (oPtr->classPtr) { @@ -1168,7 +1168,7 @@ ObjectNamespaceDeleted( Class *clsPtr = oPtr->classPtr, *mixinPtr; Method *mPtr; Tcl_Obj *filterObj, *variableObj; - int i; + int deleteAlreadyInProgress = 0, i; /* * Instruct everyone to no longer use any allocated fields of the object. @@ -1178,6 +1178,14 @@ ObjectNamespaceDeleted( */ if (oPtr->command) { + if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) { + /* + * Namespace deletion must have been triggered by a trace on command + * deletion , meaning that + */ + deleteAlreadyInProgress = 1; + } + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); } if (oPtr->myCommand) { @@ -1273,14 +1281,17 @@ ObjectNamespaceDeleted( if (clsPtr->subclasses.list) { ckfree(clsPtr->subclasses.list); + clsPtr->subclasses.list = NULL; clsPtr->subclasses.num = 0; } if (clsPtr->instances.list) { ckfree(clsPtr->instances.list); + clsPtr->instances.list = NULL; clsPtr->instances.num = 0; } if (clsPtr->mixinSubs.list) { ckfree(clsPtr->mixinSubs.list); + clsPtr->mixinSubs.list = NULL; clsPtr->mixinSubs.num = 0; } @@ -1305,7 +1316,13 @@ ObjectNamespaceDeleted( * Delete the object structure itself. */ - DelRef(oPtr); + if (deleteAlreadyInProgress) { + oPtr->classPtr = NULL; + oPtr->namespacePtr = NULL; + } else { + DelRef(oPtr); + } + } /* @@ -2435,7 +2452,7 @@ Tcl_ObjectSetMetadata( * * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject -- * - * Main entry point for object invokations. The Public* and Private* + * Main entry point for object invocations. The Public* and Private* * wrapper functions (implementations of both object instance commands * and [my]) are just thin wrappers round the main TclOOObjectCmdCore * function. Note that the core is function is NRE-aware. @@ -2520,8 +2537,8 @@ TclOOInvokeObject( * * TclOOObjectCmdCore, FinalizeObjectCall -- * - * Main function for object invokations. Does call chain creation, - * management and invokation. The function FinalizeObjectCall exists to + * Main function for object invocations. Does call chain creation, + * management and invocation. The function FinalizeObjectCall exists to * clean up after the non-recursive processing of TclOOObjectCmdCore. * * ---------------------------------------------------------------------- @@ -2533,7 +2550,7 @@ TclOOObjectCmdCore( Tcl_Interp *interp, /* The interpreter containing the object. */ int objc, /* How many arguments are being passed in. */ Tcl_Obj *const *objv, /* The array of arguments. */ - int flags, /* Whether this is an invokation through the + int flags, /* Whether this is an invocation through the * public or the private command interface. */ Class *startCls) /* Where to start in the call chain, or NULL * if we are to start at the front with @@ -2722,7 +2739,7 @@ Tcl_ObjectContextInvokeNext( * call context while we process the body. However, need to adjust the * argument-skip control because we're guaranteed to have a single prefix * arg (i.e., 'next') and not the variable amount that can happen because - * method invokations (i.e., '$obj meth' and 'my meth'), constructors + * method invocations (i.e., '$obj meth' and 'my meth'), constructors * (i.e., '$cls new' and '$cls create obj') and destructors (no args at * all) come through the same code. */ @@ -2791,7 +2808,7 @@ TclNRObjectContextInvokeNext( * call context while we process the body. However, need to adjust the * argument-skip control because we're guaranteed to have a single prefix * arg (i.e., 'next') and not the variable amount that can happen because - * method invokations (i.e., '$obj meth' and 'my meth'), constructors + * method invocations (i.e., '$obj meth' and 'my meth'), constructors * (i.e., '$cls new' and '$cls create obj') and destructors (no args at * all) come through the same code. */ diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 3e4f561..d4e1e34 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -233,7 +233,7 @@ FreeMethodNameRep( * TclOOInvokeContext -- * * Invokes a single step along a method call-chain context. Note that the - * invokation of a step along the chain can cause further steps along the + * invocation of a step along the chain can cause further steps along the * chain to be invoked. Note that this function is written to be as light * in stack usage as possible. * @@ -830,7 +830,7 @@ AddMethodToCallChain( * Call chain semantics states that methods come as *late* in the * call chain as possible. This is done by copying down the * following methods. Note that this does not change the number of - * method invokations in the call chain; it just rearranges them. + * method invocations in the call chain; it just rearranges them. */ Class *declCls = callPtr->chain[i].filterDeclarer; @@ -935,7 +935,7 @@ IsStillValid( * TclOOGetCallContext -- * * Responsible for constructing the call context, an ordered list of all - * method implementations to be called as part of a method invokation. + * method implementations to be called as part of a method invocation. * This method is central to the whole operation of the OO system. * * ---------------------------------------------------------------------- @@ -1517,7 +1517,7 @@ TclOORenderCallChain( /* * Do the actual construction of the descriptions. They consist of a list * of triples that describe the details of how a method is understood. For - * each triple, the first word is the type of invokation ("method" is + * each triple, the first word is the type of invocation ("method" is * normal, "unknown" is special because it adds the method name as an * extra argument when handled by some method types, and "filter" is * special because it's a filter method). The second word is the name of diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index b75ffdb..1eb787f 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -149,8 +149,8 @@ typedef struct Object { struct Foundation *fPtr; /* The basis for the object system. Putting * this here allows the avoidance of quite a * lot of hash lookups on the critical path - * for object invokation and creation. */ - Tcl_Namespace *namespacePtr;/* This object's tame namespace. */ + * for object invocation and creation. */ + Tcl_Namespace *namespacePtr;/* This object's namespace. */ Tcl_Command command; /* Reference to this object's public * command. */ Tcl_Command myCommand; /* Reference to this object's internal @@ -162,12 +162,12 @@ typedef struct Object { /* Classes mixed into this object. */ LIST_STATIC(Tcl_Obj *) filters; /* List of filter names. */ - struct Class *classPtr; /* All classes have this non-NULL; it points - * to the class structure. Everything else has - * this NULL. */ + struct Class *classPtr; /* This is non-NULL for all classes, and NULL + * for everything else. It points to the class + * structure. */ int refCount; /* Number of strong references to this object. * Note that there may be many more weak - * references; this mechanism is there to + * references; this mechanism exists to * avoid Tcl_Preserve. */ int flags; int creationEpoch; /* Unique value to make comparisons of objects @@ -323,7 +323,7 @@ typedef struct Foundation { } Foundation; /* - * A call context structure is built when a method is called. They contain the + * A call context structure is built when a method is called. It contains the * chain of method implementations that are to be invoked by a particular * call, and the process of calling walks the chain, with the [next] command * proceeding to the next entry in the chain. @@ -334,7 +334,7 @@ typedef struct Foundation { struct MInvoke { Method *mPtr; /* Reference to the method implementation * record. */ - int isFilter; /* Whether this is a filter invokation. */ + int isFilter; /* Whether this is a filter invocation. */ Class *filterDeclarer; /* What class decided to add the filter; if * NULL, it was added by the object. */ }; diff --git a/tests/oo.test b/tests/oo.test index 8850ea5..8face06 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1482,6 +1482,18 @@ test oo-11.4 {OO: cleanup} { lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \ [oo::object create bar2] [bar2 destroy] } {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}} +test oo-11.5 {OO: cleanup} { + oo::class create obj1 + + trace add command obj1 delete {apply {{name1 name2 action} { + set namespace [info object namespace $name1] + namespace delete $namespace + }}} + + rename obj1 {} + # No segmentation fault + return done +} done test oo-12.1 {OO: filters} { oo::class create Aclass -- cgit v0.12 From a7c17bc224dea481e831d6da7f924d8e064a5506 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 14 Feb 2018 12:14:38 +0000 Subject: Fix bug 3c32a3f8bd, segmentation fault in TclOO.c/ReleaseClassContents() for a class mixed into one of its instances. --- generic/tclOO.c | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index bae784a..8a852ff 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1006,8 +1006,18 @@ ReleaseClassContents( } for(j=0 ; jmixins.num ; j++) { Class *mixin = instancePtr->mixins.list[j]; + Class *nextMixin = NULL; if (mixin == clsPtr) { - instancePtr->mixins.list[j] = NULL; + if (j < instancePtr->mixins.num - 1) { + nextMixin = instancePtr->mixins.list[j+1]; + } + if (j == 0) { + instancePtr->mixins.num = 0; + instancePtr->mixins.list = NULL; + } else { + instancePtr->mixins.list[j-1] = nextMixin; + } + instancePtr->mixins.num -= 1; } } if (instancePtr != NULL && !IsRoot(instancePtr)) { @@ -1181,7 +1191,8 @@ ObjectNamespaceDeleted( if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) { /* * Namespace deletion must have been triggered by a trace on command - * deletion , meaning that + * deletion , meaning that ObjectRenamedTrace() is eventually going + * to be called . */ deleteAlreadyInProgress = 1; } -- cgit v0.12 From c6eb0cc51d7c4feece753d3536454bf43d7785a3 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 14 Feb 2018 12:31:33 +0000 Subject: Unit test for issue 3c32a3f8bd, Segmentation fault in TclOO.c/ReleaseClassContents() for a class mixed into one of its instances. --- tests/oo.test | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/tests/oo.test b/tests/oo.test index 8face06..0ae46f8 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1495,6 +1495,24 @@ test oo-11.5 {OO: cleanup} { return done } done +test oo-11.6 { + OO: cleanup ReleaseClassContents() where class is mixed into one of its + instances +} { + oo::class create obj1 + ::oo::define obj1 {self mixin [self]} + + ::oo::copy obj1 obj2 + ::oo::objdefine obj2 {mixin [self]} + + ::oo::copy obj2 obj3 + trace add command obj3 delete [list obj3 dying] + rename obj2 {} + + # No segmentation fault + return done +} done + test oo-12.1 {OO: filters} { oo::class create Aclass Aclass create Aobject -- cgit v0.12 From 40e9ab2e654ef81e10d38260c765346aca33077e Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 14 Feb 2018 12:52:06 +0000 Subject: More tests for bignum modules regressions. --- tests/expr.test | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/tests/expr.test b/tests/expr.test index c49a9ff..fd11870 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -5841,6 +5841,12 @@ test expr-32.6 {Bug 1585704} { test expr-32.7 {bignum regression} { expr {0%(1<<63)} } 0 +test expr-32.8 {bignum regression} { + expr {0%-(1<<63)} +} 0 +test expr-32.9 {bignum regression} { + expr {0%-(1+(1<<63))} +} 0 test expr-33.1 {parse largest long value} longIs32bit { set max_long_str 2147483647 -- cgit v0.12 From 7d25e385a2b2816630b16fdfe293c0fddd5e33fe Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 14 Feb 2018 13:00:28 +0000 Subject: Modify test oo-11.6 to not use [self], which is not avaiable until 8.7. --- tests/oo.test | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/oo.test b/tests/oo.test index 0ae46f8..3829763 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1500,10 +1500,10 @@ test oo-11.6 { instances } { oo::class create obj1 - ::oo::define obj1 {self mixin [self]} + ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]} ::oo::copy obj1 obj2 - ::oo::objdefine obj2 {mixin [self]} + ::oo::objdefine obj2 {mixin [uplevel 1 {namespace which obj2}]} ::oo::copy obj2 obj3 trace add command obj3 delete [list obj3 dying] @@ -3868,5 +3868,5 @@ cleanupTests return # Local Variables: -# mode: tcl +# MODE: Tcl # End: -- cgit v0.12 From 1e854210b71ecee27e16ad922e8f4bb312605114 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 14 Feb 2018 13:37:27 +0000 Subject: Rewrite documentation in comments for brevity and clarity. --- generic/tclListObj.c | 593 +++++++++++++++++++++++++-------------------------- generic/tclObj.c | 31 +-- generic/tclUtil.c | 37 ++-- 3 files changed, 325 insertions(+), 336 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 3a1555d..0d37821 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -55,20 +55,22 @@ const Tcl_ObjType tclListType = { * * NewListIntRep -- * - * Creates a list internal rep with space for objc elements. objc - * must be > 0. If objv!=NULL, initializes with the first objc values - * in that array. If objv==NULL, initalize list internal rep to have - * 0 elements, with space to add objc more. Flag value "p" indicates + * Creates a 'List' structure with space for 'objc' elements. 'objc' must + * be > 0. If 'objv' is not NULL, The list is initialized with first + * 'objc' values in that array. Otherwise the list is initialized to have + * 0 elements, with space to add 'objc' more. Flag value 'p' indicates * how to behave on failure. * - * Results: - * A new List struct with refCount 0 is returned. If some failure - * prevents this then if p=0, NULL is returned and otherwise the - * routine panics. + * Value * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * A new 'List' structure with refCount 0. If some failure + * prevents this NULL is returned if 'p' is 0 , and 'Tcl_Panic' + * is called if it is not. + * + * Effect + * + * The refCount of each value in 'objv' is incremented as it is added + * to the list. * *---------------------------------------------------------------------- */ @@ -132,22 +134,10 @@ NewListIntRep( /* *---------------------------------------------------------------------- * - * AttemptNewList -- - * - * Creates a list internal rep with space for objc elements. objc - * must be > 0. If objv!=NULL, initializes with the first objc values - * in that array. If objv==NULL, initalize list internal rep to have - * 0 elements, with space to add objc more. - * - * Results: - * A new List struct with refCount 0 is returned. If some failure - * prevents this then NULL is returned, and an error message is left - * in the interp result, unless interp is NULL. - * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * AttemptNewList -- * + * Like NewListIntRep, but additionally sets an error message on failure. + * *---------------------------------------------------------------------- */ @@ -179,23 +169,20 @@ AttemptNewList( * * Tcl_NewListObj -- * - * This function is normally called when not debugging: i.e., when - * TCL_MEM_DEBUG is not defined. It creates a new list object from an - * (objc,objv) array: that is, each of the objc elements of the array - * referenced by objv is inserted as an element into a new Tcl object. + * Creates a new list object and adds values to it. When TCL_MEM_DEBUG is + * defined, 'Tcl_DbNewListObj' is called instead. * - * When TCL_MEM_DEBUG is defined, this function just returns the result - * of calling the debugging version Tcl_DbNewListObj. + * Value * - * Results: - * A new list object is returned that is initialized from the object - * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation is left - * NULL. The resulting new list object has ref count 0. + * A new list 'Tcl_Obj' to which is appended values from 'objv', or if + * 'objc' is less than or equal to zero, a list 'Tcl_Obj' having no + * elements. The string representation of the new 'Tcl_Obj' is set to + * NULL. The refCount of the list is 0. * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * Effect + * + * The refCount of each elements in 'objv' is incremented as it is added + * to the list. * *---------------------------------------------------------------------- */ @@ -246,28 +233,14 @@ Tcl_NewListObj( /* *---------------------------------------------------------------------- * - * Tcl_DbNewListObj -- - * - * This function is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It creates new list objects. It is the same - * as the Tcl_NewListObj function above except that it calls - * Tcl_DbCkalloc directly with the file name and line number from its - * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when - * reporting objects that haven't been freed. - * - * When TCL_MEM_DEBUG is not defined, this function just returns the - * result of calling Tcl_NewListObj. - * - * Results: - * A new list object is returned that is initialized from the object - * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation is left - * NULL. The new list object has ref count 0. - * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * Tcl_DbNewListObj -- + * + * Like 'Tcl_NewListObj', but it calls Tcl_DbCkalloc directly with the + * file name and line number from its caller. This simplifies debugging + * since the [memory active] command will report the correct file + * name and line number when reporting objects that haven't been freed. + * + * When TCL_MEM_DEBUG is not defined, 'Tcl_NewListObj' is called instead. * *---------------------------------------------------------------------- */ @@ -328,19 +301,8 @@ Tcl_DbNewListObj( * * Tcl_SetListObj -- * - * Modify an object to be a list containing each of the objc elements of - * the object array referenced by objv. - * - * Results: - * None. - * - * Side effects: - * The object is made a list object and is initialized from the object - * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation is left - * NULL. The ref counts of the elements in objv are incremented since the - * list now refers to them. The object's old string and internal - * representations are freed and its type is set NULL. + * Like 'Tcl_NewListObj', but operates on an existing 'Tcl_Obj'instead of + * creating a new one. * *---------------------------------------------------------------------- */ @@ -384,18 +346,20 @@ Tcl_SetListObj( * * TclListObjCopy -- * - * Makes a "pure list" copy of a list value. This provides for the C - * level a counterpart of the [lrange $list 0 end] command, while using - * internals details to be as efficient as possible. + * Creates a new 'Tcl_Obj' which is a pure copy of a list value. This + * provides for the C level a counterpart of the [lrange $list 0 end] + * command, while using internals details to be as efficient as possible. + * + * Value * - * Results: - * Normally returns a pointer to a new Tcl_Obj, that contains the same - * list value as *listPtr does. The returned Tcl_Obj has a refCount of - * zero. If *listPtr does not hold a list, NULL is returned, and if - * interp is non-NULL, an error message is recorded there. + * The address of the new 'Tcl_Obj' which shares its internal + * representation with 'listPtr', and whose refCount is 0. If 'listPtr' + * is not actually a list, the value is NULL, and an error message is left + * in 'interp' if it is not NULL. * - * Side effects: - * None. + * Effect + * + * 'listPtr' is converted to a list if it isn't one already. * *---------------------------------------------------------------------- */ @@ -425,27 +389,30 @@ TclListObjCopy( * * Tcl_ListObjGetElements -- * - * This function returns an (objc,objv) array of the elements in a list - * object. + * Retreive the elements in a list 'Tcl_Obj'. + * + * Value + * + * TCL_OK + * + * A count of list elements is stored, 'objcPtr', And a pointer to the + * array of elements in the list is stored in 'objvPtr'. * - * Results: - * The return value is normally TCL_OK; in this case *objcPtr is set to - * the count of list elements and *objvPtr is set to a pointer to an - * array of (*objcPtr) pointers to each list element. If listPtr does not - * refer to a list object and the object can not be converted to one, - * TCL_ERROR is returned and an error message will be left in the - * interpreter's result if interp is not NULL. + * The elements accessible via 'objvPtr' should be treated as readonly + * and the refCount for each object is _not_ incremented; the caller + * must do that if it holds on to a reference. Furthermore, the + * pointer and length returned by this function may change as soon as + * any function is called on the list object. Be careful about + * retaining the pointer in a local data structure. * - * The objects referenced by the returned array should be treated as - * readonly and their ref counts are _not_ incremented; the caller must - * do that if it holds on to a reference. Furthermore, the pointer and - * length returned by this function may change as soon as any function is - * called on the list object; be careful about retaining the pointer in a - * local data structure. + * TCL_ERROR * - * Side effects: - * The possible conversion of the object referenced by listPtr - * to a list object. + * 'listPtr' is not a valid list. An error message is left in the + * interpreter's result if 'interp' is not NULL. + * + * Effect + * + * 'listPtr' is converted to a list object if it isn't one already. * *---------------------------------------------------------------------- */ @@ -486,20 +453,27 @@ Tcl_ListObjGetElements( * * Tcl_ListObjAppendList -- * - * This function appends the elements in the list value referenced by - * elemListPtr to the list value referenced by listPtr. + * Appends the elements of elemListPtr to those of listPtr. + * + * Value + * + * TCL_OK + * + * Success. * - * Results: - * The return value is normally TCL_OK. If listPtr or elemListPtr do not - * refer to list values, TCL_ERROR is returned and an error message is - * left in the interpreter's result if interp is not NULL. + * TCL_ERROR * - * Side effects: - * The reference counts of the elements in elemListPtr are incremented - * since the list now refers to them. listPtr and elemListPtr are - * converted, if necessary, to list objects. Also, appending the new - * elements may cause listObj's array of element pointers to grow. - * listPtr's old string representation, if any, is invalidated. + * 'listPtr' or 'elemListPtr' are not valid lists. An error + * message is left in the interpreter's result if 'interp' is not NULL. + * + * Effect + * + * The reference count of each element of 'elemListPtr' as it is added to + * 'listPtr'. 'listPtr' and 'elemListPtr' are converted to 'tclListType' + * if they are not already. Appending the new elements may cause the + * array of element pointers in 'listObj' to grow. If any objects are + * appended to 'listPtr'. Any preexisting string representation of + * 'listPtr' is invalidated. * *---------------------------------------------------------------------- */ @@ -538,24 +512,27 @@ Tcl_ListObjAppendList( * * Tcl_ListObjAppendElement -- * - * This function is a special purpose version of Tcl_ListObjAppendList: - * it appends a single object referenced by objPtr to the list object - * referenced by listPtr. If listPtr is not already a list object, an - * attempt will be made to convert it to one. - * - * Results: - * The return value is normally TCL_OK; in this case objPtr is added to - * the end of listPtr's list. If listPtr does not refer to a list object - * and the object can not be converted to one, TCL_ERROR is returned and - * an error message will be left in the interpreter's result if interp is - * not NULL. - * - * Side effects: - * The ref count of objPtr is incremented since the list now refers to - * it. listPtr will be converted, if necessary, to a list object. Also, - * appending the new element may cause listObj's array of element - * pointers to grow. listPtr's old string representation, if any, is - * invalidated. + * Like 'Tcl_ListObjAppendList', but Appends a single value to a list. + * + * Value + * + * TCL_OK + * + * 'objPtr' is appended to the elements of 'listPtr'. + * + * TCL_ERROR + * + * listPtr does not refer to a list object and the object can not be + * converted to one. An error message will be left in the + * interpreter's result if interp is not NULL. + * + * Effect + * + * If 'listPtr' is not already of type 'tclListType', it is converted. + * The 'refCount' of 'objPtr' is incremented as it is added to 'listPtr'. + * Appending the new element may cause the the array of element pointers + * in 'listObj' to grow. Any preexisting string representation of + * 'listPtr' is invalidated. * *---------------------------------------------------------------------- */ @@ -706,23 +683,27 @@ Tcl_ListObjAppendElement( * * Tcl_ListObjIndex -- * - * This function returns a pointer to the index'th object from the list - * referenced by listPtr. The first element has index 0. If index is - * negative or greater than or equal to the number of elements in the - * list, a NULL is returned. If listPtr is not a list object, an attempt - * will be made to convert it to a list. + * Retrieve a pointer to the element of 'listPtr' at 'index'. The index + * of the first element is 0. + * + * Value + * + * TCL_OK * - * Results: - * The return value is normally TCL_OK; in this case objPtrPtr is set to - * the Tcl_Obj pointer for the index'th list element or NULL if index is - * out of range. This object should be treated as readonly and its ref - * count is _not_ incremented; the caller must do that if it holds on to - * the reference. If listPtr does not refer to a list and can't be - * converted to one, TCL_ERROR is returned and an error message is left - * in the interpreter's result if interp is not NULL. + * A pointer to the element at 'index' is stored in 'objPtrPtr'. If + * 'index' is out of range, NULL is stored in 'objPtrPtr'. This + * object should be treated as readonly and its 'refCount' is _not_ + * incremented. The caller must do that if it holds on to the + * reference. + * + * TCL_ERROR * - * Side effects: - * listPtr will be converted, if necessary, to a list object. + * 'listPtr' is not a valid list. An an error message is left in the + * interpreter's result if 'interp' is not NULL. + * + * Effect + * + * If 'listPtr' is not already of type 'tclListType', it is converted. * *---------------------------------------------------------------------- */ @@ -764,19 +745,20 @@ Tcl_ListObjIndex( * * Tcl_ListObjLength -- * - * This function returns the number of elements in a list object. If the - * object is not already a list object, an attempt will be made to - * convert it to one. + * Retrieve the number of elements in a list. + * + * Value + * + * TCL_OK + * + * A count of list elements is stored at the address provided by + * 'intPtr'. If 'listPtr' is not already of type 'tclListPtr', it is + * converted. * - * Results: - * The return value is normally TCL_OK; in this case *intPtr will be set - * to the integer count of list elements. If listPtr does not refer to a - * list object and the object can not be converted to one, TCL_ERROR is - * returned and an error message will be left in the interpreter's result - * if interp is not NULL. + * TCL_ERROR * - * Side effects: - * The possible conversion of the argument object to a list object. + * 'listPtr' is not a valid list. An error message will be left in + * the interpreter's result if 'interp' is not NULL. * *---------------------------------------------------------------------- */ @@ -812,35 +794,36 @@ Tcl_ListObjLength( * * Tcl_ListObjReplace -- * - * This function replaces zero or more elements of the list referenced by - * listPtr with the objects from an (objc,objv) array. The objc elements - * of the array referenced by objv replace the count elements in listPtr - * starting at first. - * - * If the argument first is zero or negative, it refers to the first - * element. If first is greater than or equal to the number of elements - * in the list, then no elements are deleted; the new elements are - * appended to the list. Count gives the number of elements to replace. - * If count is zero or negative then no elements are deleted; the new - * elements are simply inserted before first. - * - * The argument objv refers to an array of objc pointers to the new - * elements to be added to listPtr in place of those that were deleted. - * If objv is NULL, no new elements are added. If listPtr is not a list - * object, an attempt will be made to convert it to one. - * - * Results: - * The return value is normally TCL_OK. If listPtr does not refer to a - * list object and can not be converted to one, TCL_ERROR is returned and - * an error message will be left in the interpreter's result if interp is - * not NULL. - * - * Side effects: - * The ref counts of the objc elements in objv are incremented since the - * resulting list now refers to them. Similarly, the ref counts for - * replaced objects are decremented. listPtr is converted, if necessary, - * to a list object. listPtr's old string representation, if any, is - * freed. + * Replace values in a list. + * + * If 'first' is zero or negative, it refers to the first element. If + * 'first' outside the range of elements in the list, no elements are + * deleted. + * + * If 'count' is zero or negative no elements are deleted, and any new + * elements are inserted at the beginning of the list. + * + * Value + * + * TCL_OK + * + * The first 'objc' values of 'objv' replaced 'count' elements in 'listPtr' + * starting at 'first'. If 'objc' 0, no new elements are added. + * + * TCL_ERROR + * + * 'listPtr' is not a valid list. An error message is left in the + * interpreter's result if 'interp' is not NULL. + * + * Effect + * + * If 'listPtr' is not of type 'tclListType', it is converted if possible. + * + * The 'refCount' of each element appended to the list is incremented. + * Similarly, the 'refCount' for each replaced element is decremented. + * + * If 'listPtr' is modified, any previous string representation is + * invalidated. * *---------------------------------------------------------------------- */ @@ -1098,22 +1081,19 @@ Tcl_ListObjReplace( * * TclLindexList -- * - * This procedure handles the 'lindex' command when objc==3. + * Implements the 'lindex' command when objc==3. * - * Results: - * Returns a pointer to the object extracted, or NULL if an error - * occurred. The returned object already includes one reference count for - * the pointer returned. + * Implemented entirely as a wrapper around 'TclLindexFlat'. Reconfigures + * the argument format into required form while taking care to manage + * shimmering so as to tend to keep the most useful intreps + * and/or avoid the most expensive conversions. * - * Side effects: - * None. + * Value * - * Notes: - * This procedure is implemented entirely as a wrapper around - * TclLindexFlat. All it does is reconfigure the argument format into the - * form required by TclLindexFlat, while taking care to manage shimmering - * in such a way that we tend to keep the most useful intreps and/or - * avoid the most expensive conversions. + * A pointer to the specified element, with its 'refCount' incremented, or + * NULL if an error occurred. + * + * Notes * *---------------------------------------------------------------------- */ @@ -1185,25 +1165,20 @@ TclLindexList( /* *---------------------------------------------------------------------- * - * TclLindexFlat -- + * TclLindexFlat -- + * + * The core of the 'lindex' command, with all index + * arguments presented as a flat list. * - * This procedure is the core of the 'lindex' command, with all index - * arguments presented as a flat list. + * Value * - * Results: - * Returns a pointer to the object extracted, or NULL if an error - * occurred. The returned object already includes one reference count for - * the pointer returned. + * A pointer to the object extracted, with its 'refCount' incremented, or + * NULL if an error occurred. Thus, the calling code will usually do + * something like: * - * Side effects: - * None. + * Tcl_SetObjResult(interp, result); + * Tcl_DecrRefCount(result); * - * Notes: - * The reference count of the returned object includes one reference - * corresponding to the pointer returned. Thus, the calling code will - * usually do something like: - * Tcl_SetObjResult(interp, result); - * Tcl_DecrRefCount(result); * *---------------------------------------------------------------------- */ @@ -1279,23 +1254,16 @@ TclLindexFlat( * * TclLsetList -- * - * Core of the 'lset' command when objc == 4. Objv[2] may be either a + * The core of [lset] when objc == 4. Objv[2] may be either a * scalar index or a list of indices. * - * Results: - * Returns the new value of the list variable, or NULL if there was an - * error. The returned object includes one reference count for the - * pointer returned. + * Implemented entirely as a wrapper around 'TclLindexFlat', as described + * for 'TclLindexList'. * - * Side effects: - * None. + * Value * - * Notes: - * This procedure is implemented entirely as a wrapper around - * TclLsetFlat. All it does is reconfigure the argument format into the - * form required by TclLsetFlat, while taking care to manage shimmering - * in such a way that we tend to keep the most useful intreps and/or - * avoid the most expensive conversions. + * The new list, with the 'refCount' of 'valuPtr' incremented, or NULL if + * there was an error. * *---------------------------------------------------------------------- */ @@ -1357,36 +1325,39 @@ TclLsetList( * * Core engine of the 'lset' command. * - * Results: - * Returns the new value of the list variable, or NULL if an error - * occurred. The returned object includes one reference count for the - * pointer returned. - * - * Side effects: - * On entry, the reference count of the variable value does not reflect - * any references held on the stack. The first action of this function is - * to determine whether the object is shared, and to duplicate it if it - * is. The reference count of the duplicate is incremented. At this - * point, the reference count will be 1 for either case, so that the - * object will appear to be unshared. - * - * If an error occurs, and the object has been duplicated, the reference - * count on the duplicate is decremented so that it is now 0: this - * dismisses any memory that was allocated by this function. - * - * If no error occurs, the reference count of the original object is - * incremented if the object has not been duplicated, and nothing is done - * to a reference count of the duplicate. Now the reference count of an - * unduplicated object is 2 (the returned pointer, plus the one stored in - * the variable). The reference count of a duplicate object is 1, - * reflecting that the returned pointer is the only active reference. The - * caller is expected to store the returned value back in the variable - * and decrement its reference count. (INST_STORE_* does exactly this.) - * - * Surgery is performed on the unshared list value to produce the result. - * TclLsetFlat maintains a linked list of Tcl_Obj's whose string + * Value + * + * The resulting list + * + * The 'refCount' of 'valuePtr' is incremented. If 'listPtr' was not + * duplicated, its 'refCount' is incremented. The reference count of + * an unduplicated object is therefore 2 (one for the returned pointer + * and one for the variable that holds it). The reference count of a + * duplicate object is 1, reflecting that result is the only active + * reference. The caller is expected to store the result in the + * variable and decrement its reference count. (INST_STORE_* does + * exactly this.) + * + * NULL + * + * An error occurred. If 'listPtr' was duplicated, the reference + * count on the duplicate is decremented so that it is 0, causing any + * memory allocated by this function to be freed. + * + * + * Effect + * + * On entry, the reference count of 'listPtr' does not reflect any + * references held on the stack. The first action of this function is to + * determine whether 'listPtr' is shared and to create a duplicate + * unshared copy if it is. The reference count of the duplicate is + * incremented. At this point, the reference count is 1 in either case so + * that the object is considered unshared. + * + * The unshared list is altered directly to produce the result. + * 'TclLsetFlat' maintains a linked list of 'Tcl_Obj' values whose string * representations must be spoilt by threading via 'ptr2' of the - * two-pointer internal representation. On entry to TclLsetFlat, the + * two-pointer internal representation. On entry to 'TclLsetFlat', the * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any * Tcl_Obj that has been modified is set to NULL. * @@ -1601,26 +1572,38 @@ TclLsetFlat( * * TclListObjSetElement -- * - * Set a single element of a list to a specified value + * Set a single element of a list to a specified value. * - * Results: - * The return value is normally TCL_OK. If listPtr does not refer to a - * list object and cannot be converted to one, TCL_ERROR is returned and - * an error message will be left in the interpreter result if interp is - * not NULL. Similarly, if index designates an element outside the range - * [0..listLength-1], where listLength is the count of elements in the - * list object designated by listPtr, TCL_ERROR is returned and an error - * message is left in the interpreter result. + * It is the caller's responsibility to invalidate the string + * representation of the 'listPtr'. * - * Side effects: - * Tcl_Panic if listPtr designates a shared object. Otherwise, attempts - * to convert it to a list with a non-shared internal rep. Decrements the - * ref count of the object at the specified index within the list, - * replaces with the object designated by valuePtr, and increments the - * ref count of the replacement object. + * Value + * + * TCL_OK + * + * Success. + * + * TCL_ERROR + * + * 'listPtr' does not refer to a list object and cannot be converted + * to one. An error message will be left in the interpreter result if + * interp is not NULL. + * + * TCL_ERROR + * + * An index designates an element outside the range [0..listLength-1], + * where 'listLength' is the count of elements in the list object + * designated by 'listPtr'. An error message is left in the + * interpreter result. + * + * Effect + * + * If 'listPtr' designates a shared object, 'Tcl_Panic' is called. If + * 'listPtr' is not already of type 'tclListType', it is converted and the + * internal representation is unshared. The 'refCount' of the element at + * 'index' is decremented and replaced in the list with the 'valuePtr', + * whose 'refCount' in turn is incremented. * - * It is the caller's responsibility to invalidate the string - * representation of the object. * *---------------------------------------------------------------------- */ @@ -1738,16 +1721,14 @@ TclListObjSetElement( * * FreeListInternalRep -- * - * Deallocate the storage associated with a list object's internal - * representation. + * Deallocate the storage associated with the internal representation of a + * a list object. * - * Results: - * None. + * Effect * - * Side effects: - * Frees listPtr's List* internal representation and sets listPtr's - * internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts of all - * element objects, which may free them. + * The storage for the internal 'List' pointer of 'listPtr' is freed, the + * 'internalRep.twoPtrValue.ptr1' of 'listPtr' is set to NULL, and the 'refCount' + * of each element of the list is decremented. * *---------------------------------------------------------------------- */ @@ -1776,14 +1757,12 @@ FreeListInternalRep( * * DupListInternalRep -- * - * Initialize the internal representation of a list Tcl_Obj to share the + * Initialize the internal representation of a list 'Tcl_Obj' to share the * internal representation of an existing list object. * - * Results: - * None. + * Effect * - * Side effects: - * The reference count of the List internal rep is incremented. + * The 'refCount' of the List internal rep is incremented. * *---------------------------------------------------------------------- */ @@ -1803,16 +1782,20 @@ DupListInternalRep( * * SetListFromAny -- * - * Attempt to generate a list internal form for the Tcl object "objPtr". + * Convert any object to a list. + * + * Value * - * Results: - * The return value is TCL_OK or TCL_ERROR. If an error occurs during - * conversion, an error message is left in the interpreter's result - * unless "interp" is NULL. + * TCL_OK + * + * Success. The internal representation of 'objPtr' is set, and the type + * of 'objPtr' is 'tclListType'. + * + * TCL_ERROR + * + * An error occured during conversion. An error message is left in the + * interpreter's result if 'interp' is not NULL. * - * Side effects: - * If no error occurs, a list is stored as "objPtr"s internal - * representation. * *---------------------------------------------------------------------- */ @@ -1937,18 +1920,16 @@ SetListFromAny( * * UpdateStringOfList -- * - * Update the string representation for a list object. Note: This - * function does not invalidate an existing old string rep so storage - * will be lost if this has not already been done. + * Update the string representation for a list object. + * + * Any previously-exising string representation is not invalidated, so + * storage is lost if this has not been taken care of. * - * Results: - * None. + * Effect * - * Side effects: - * The object's string is set to a valid string that results from the - * list-to-string conversion. This string will be empty if the list has - * no elements. The list internal representation should not be NULL and - * we assume it is not NULL. + * The string representation of 'listPtr' is set to the resulting string. + * This string will be empty if the list has no elements. It is assumed + * that the list internal representation is not NULL. * *---------------------------------------------------------------------- */ diff --git a/generic/tclObj.c b/generic/tclObj.c index 3bf5b8e..a75ecdd 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2467,23 +2467,26 @@ Tcl_SetIntObj( * * Tcl_GetIntFromObj -- * - * Attempt to return an int from the Tcl object "objPtr". If the object - * is not already an int, an attempt will be made to convert it to one. + * Retrieve the integer value of 'objPtr'. * - * Integer and long integer objects share the same "integer" type - * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by an - * int. + * Value * - * Results: - * The return value is a standard Tcl object result. If an error occurs - * during conversion or if the long integer held by the object can not be - * represented by an int, an error message is left in the interpreter's - * result unless "interp" is NULL. + * TCL_OK * - * Side effects: - * If the object is not already an int, the conversion will free any old - * internal representation. + * Success. + * + * TCL_ERROR + * + * An error occurred during conversion or the integral value can not + * be represented as an integer (it might be too large). An error + * message is left in the interpreter's result if 'interp' is not + * NULL. + * + * Effect + * + * 'objPtr' is converted to an integer if necessary if it is not one + * already. The conversion frees any previously-existing internal + * representation. * *---------------------------------------------------------------------- */ diff --git a/generic/tclUtil.c b/generic/tclUtil.c index feee9c5..396f992 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3530,22 +3530,27 @@ TclFormatInt( * * TclGetIntForIndex -- * - * This function returns an integer corresponding to the list index held - * in a Tcl object. The Tcl object's value is expected to be in the - * format integer([+-]integer)? or the format end([+-]integer)?. - * - * Results: - * The return value is normally TCL_OK, which means that the index was - * successfully stored into the location referenced by "indexPtr". If the - * Tcl object referenced by "objPtr" has the value "end", the value - * stored is "endValue". If "objPtr"s values is not of one of the - * expected formats, TCL_ERROR is returned and, if "interp" is non-NULL, - * an error message is left in the interpreter's result object. - * - * Side effects: - * The object referenced by "objPtr" might be converted to an integer, - * wide integer, or end-based-index object. - * + * Provides an integer corresponding to the list index held in a Tcl + * object. The string value 'objPtr' is expected have the format + * integer([+-]integer)? or end([+-]integer)?. + * + * Value + * TCL_OK + * + * The index is stored at the address given by by 'indexPtr'. If + * 'objPtr' has the value "end", the value stored is 'endValue'. + * + * TCL_ERROR + * + * The value of 'objPtr' does not have one of the expected formats. If + * 'interp' is non-NULL, an error message is left in the interpreter's + * result object. + * + * Effect + * + * The object referenced by 'objPtr' is converted, as needed, to an + * integer, wide integer, or end-based-index object. + * *---------------------------------------------------------------------- */ -- cgit v0.12 From 5d5bd4cd5514c5e0361bb9762e8e560384d4e8a6 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 14 Feb 2018 14:05:04 +0000 Subject: Modify TclCreateProc to handle arbitrary argument names, not just ASCII. --- generic/tclExecute.c | 4 +-- generic/tclInt.h | 2 +- generic/tclProc.c | 96 +++++++++++++++++++++++----------------------------- 3 files changed, 45 insertions(+), 57 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 761a23e..93ed50b 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1333,12 +1333,12 @@ TclStackAlloc( int numBytes) { Interp *iPtr = (Interp *) interp; - int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); + int numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { return (void *) ckalloc(numBytes); } - + numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); return (void *) StackAllocWords(interp, numWords); } diff --git a/generic/tclInt.h b/generic/tclInt.h index ac67ebd..71a55cc 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4433,7 +4433,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, /* *---------------------------------------------------------------- - * Macro used by the Tcl core to increment a namespace's export export epoch + * Macro used by the Tcl core to increment a namespace's export epoch * counter. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr); diff --git a/generic/tclProc.c b/generic/tclProc.c index 5c68e17..9940f9d 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -393,13 +393,13 @@ TclCreateProc( Proc **procPtrPtr) /* Returns: pointer to proc data. */ { Interp *iPtr = (Interp *) interp; - const char **argArray = NULL; register Proc *procPtr; - int i, length, result, numArgs; - const char *args, *bytes, *p; + int i, result, numArgs, plen; + const char *bytes, *argname, *argnamei; + char argnamelast; register CompiledLocal *localPtr = NULL; - Tcl_Obj *defPtr; + Tcl_Obj *defPtr, *errorObj, **argArray; int precompiled = 0; if (bodyPtr->typePtr == &tclProcBodyType) { @@ -436,6 +436,7 @@ TclCreateProc( */ if (Tcl_IsShared(bodyPtr)) { + int length; Tcl_Obj *sharedBodyPtr = bodyPtr; bytes = TclGetStringFromObj(bodyPtr, &length); @@ -473,12 +474,9 @@ TclCreateProc( * argument specifier. If the body is precompiled, processing is limited * to checking that the parsed argument is consistent with the one stored * in the Proc. - * - * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS. */ - args = TclGetStringFromObj(argsPtr, &length); - result = Tcl_SplitList(interp, args, &numArgs, &argArray); + result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray); if (result != TCL_OK) { goto procError; } @@ -501,28 +499,28 @@ TclCreateProc( for (i = 0; i < numArgs; i++) { int fieldCount, nameLength, valueLength; - const char **fieldValues; + Tcl_Obj **fieldValues; /* * Now divide the specifier up into name and default. */ - result = Tcl_SplitList(interp, argArray[i], &fieldCount, + result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; } if (fieldCount > 2) { - ckfree(fieldValues); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "too many fields in argument specifier \"%s\"", - argArray[i])); + errorObj = Tcl_NewStringObj( + "too many fields in argument specifier \"", -1); + Tcl_AppendObjToObj(errorObj, argArray[i]); + Tcl_AppendToObj(errorObj, "\"", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - if ((fieldCount == 0) || (*fieldValues[0] == 0)) { - ckfree(fieldValues); + if ((fieldCount == 0) || (fieldValues[0]->length == 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", @@ -530,9 +528,10 @@ TclCreateProc( goto procError; } - nameLength = strlen(fieldValues[0]); + nameLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[0]), fieldValues[0]->length); if (fieldCount == 2) { - valueLength = strlen(fieldValues[1]); + valueLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[1]), + fieldValues[1]->length); } else { valueLength = 0; } @@ -541,33 +540,29 @@ TclCreateProc( * Check that the formal parameter name is a scalar. */ - p = fieldValues[0]; - while (*p != '\0') { - if (*p == '(') { - const char *q = p; - do { - q++; - } while (*q != '\0'); - q--; - if (*q == ')') { /* We have an array element. */ + argname = Tcl_GetStringFromObj(fieldValues[0], &plen); + argnamei = argname; + argnamelast = argname[plen-1]; + while (plen--) { + if (argnamei[0] == '(') { + if (argnamelast == ')') { /* We have an array element. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "formal parameter \"%s\" is an array element", - fieldValues[0])); - ckfree(fieldValues); + Tcl_GetString(fieldValues[0]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - } else if ((*p == ':') && (*(p+1) == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "formal parameter \"%s\" is not a simple name", - fieldValues[0])); - ckfree(fieldValues); + } else if ((argnamei[0] == ':') && (argnamei[1] == ':')) { + errorObj = Tcl_NewStringObj("formal parameter \"", -1); + Tcl_AppendObjToObj(errorObj, fieldValues[0]); + Tcl_AppendToObj(errorObj, "\" is not a simple name", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - p++; + argnamei = Tcl_UtfNext(argnamei); } if (precompiled) { @@ -583,7 +578,7 @@ TclCreateProc( */ if ((localPtr->nameLength != nameLength) - || (strcmp(localPtr->name, fieldValues[0])) + || (Tcl_UtfNcmp(localPtr->name, argname, nameLength)) || (localPtr->frameIndex != i) || !(localPtr->flags & VAR_ARGUMENT) || (localPtr->defValuePtr == NULL && fieldCount == 2) @@ -591,7 +586,6 @@ TclCreateProc( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); - ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; @@ -607,12 +601,13 @@ TclCreateProc( &tmpLength); if ((valueLength != tmpLength) || - strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": formal parameter \"%s\" has " - "default value inconsistent with precompiled body", - procName, fieldValues[0])); - ckfree(fieldValues); + Tcl_UtfNcmp(Tcl_GetString(fieldValues[1]), tmpPtr, tmpLength)) { + errorObj = Tcl_ObjPrintf( + "procedure \"%s\": formal parameter \"" ,procName); + Tcl_AppendObjToObj(errorObj, fieldValues[0]); + Tcl_AppendToObj(errorObj, "\" has " + "default value inconsistent with precompiled body", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; @@ -632,7 +627,7 @@ TclCreateProc( * local variables for the argument. */ - localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1); + localPtr = ckalloc(TclOffset(CompiledLocal, name) + fieldValues[0]->length +1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -640,19 +635,18 @@ TclCreateProc( procPtr->lastLocalPtr = localPtr; } localPtr->nextPtr = NULL; - localPtr->nameLength = nameLength; + localPtr->nameLength = Tcl_NumUtfChars(argname, fieldValues[0]->length); localPtr->frameIndex = i; localPtr->flags = VAR_ARGUMENT; localPtr->resolveInfo = NULL; if (fieldCount == 2) { - localPtr->defValuePtr = - Tcl_NewStringObj(fieldValues[1], valueLength); + localPtr->defValuePtr = fieldValues[1]; Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } - memcpy(localPtr->name, fieldValues[0], nameLength + 1); + memcpy(localPtr->name, argname, fieldValues[0]->length + 1); if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') @@ -660,12 +654,9 @@ TclCreateProc( localPtr->flags |= VAR_IS_ARGS; } } - - ckfree(fieldValues); } *procPtrPtr = procPtr; - ckfree(argArray); return TCL_OK; procError: @@ -686,9 +677,6 @@ TclCreateProc( } ckfree(procPtr); } - if (argArray != NULL) { - ckfree(argArray); - } return TCL_ERROR; } -- cgit v0.12