summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclConfig.c256
-rw-r--r--generic/tclFCmd.c615
-rw-r--r--generic/tclGet.c80
-rw-r--r--generic/tclPreserve.c272
-rw-r--r--generic/tclResult.c541
-rw-r--r--generic/tclStringObj.c995
-rwxr-xr-xgeneric/tclThreadAlloc.c194
-rw-r--r--generic/tclTimer.c596
-rw-r--r--generic/tclUtil.c1486
9 files changed, 2607 insertions, 2428 deletions
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index f9c6dda..49eb04b 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -1,4 +1,4 @@
-/*
+/*
* tclConfig.c --
*
* This file provides the facilities which allow Tcl and other packages
@@ -6,10 +6,10 @@
*
* Copyright (c) 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net>
*
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclConfig.c,v 1.8 2005/05/10 18:34:28 kennykb Exp $
+ * RCS: @(#) $Id: tclConfig.c,v 1.9 2005/07/24 22:56:43 dkf Exp $
*/
#include "tclInt.h"
@@ -19,13 +19,12 @@
/*
* Internal structure to hold embedded configuration information.
*
- * Our structure is a two-level dictionary associated with the
- * 'interp'. The first level is keyed with the package name and maps
- * to the dictionary for that package. The package dictionary is keyed
- * with metadata keys and maps to the metadata value for that
- * key. This is package specific. The metadata values are in UTF8,
- * converted from the external representation given to us by the
- * caller.
+ * Our structure is a two-level dictionary associated with the 'interp'. The
+ * first level is keyed with the package name and maps to the dictionary for
+ * that package. The package dictionary is keyed with metadata keys and maps
+ * to the metadata value for that key. This is package specific. The metadata
+ * values are in UTF-8, converted from the external representation given to us
+ * by the caller.
*/
#define ASSOC_KEY "tclPackageAboutDict"
@@ -34,26 +33,20 @@
* Static functions in this file:
*/
-static int
-QueryConfigObjCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv));
-
-static void
-QueryConfigDelete _ANSI_ARGS_((ClientData clientData));
-
-static Tcl_Obj*
-GetConfigDict _ANSI_ARGS_((Tcl_Interp* interp));
-
-static void
-ConfigDictDeleteProc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp));
+static int QueryConfigObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ struct Tcl_Obj * CONST * objv));
+static void QueryConfigDelete _ANSI_ARGS_((ClientData clientData));
+static Tcl_Obj * GetConfigDict _ANSI_ARGS_((Tcl_Interp* interp));
+static void ConfigDictDeleteProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp));
/*
*----------------------------------------------------------------------
*
* Tcl_RegisterConfig --
*
- * See TIP#59 for details on what this procedure does.
+ * See TIP#59 for details on what this function does.
*
* Results:
* None.
@@ -65,110 +58,108 @@ ConfigDictDeleteProc _ANSI_ARGS_((ClientData clientData,
*/
void
-Tcl_RegisterConfig (interp, pkgName, configuration, valEncoding)
- Tcl_Interp* interp; /* Interpreter the configuration
- * command is registered in. */
- CONST char* pkgName; /* Name of the package registering
- * the embedded configuration. ASCII,
- * thus in UTF-8 too. */
- Tcl_Config* configuration; /* Embedded configuration */
- CONST char* valEncoding; /* Name of the encoding used to
- * store the configuration values,
- * ASCII, thus UTF-8 */
+Tcl_RegisterConfig(interp, pkgName, configuration, valEncoding)
+ Tcl_Interp *interp; /* Interpreter the configuration command is
+ * registered in. */
+ CONST char *pkgName; /* Name of the package registering the
+ * embedded configuration. ASCII, thus in
+ * UTF-8 too. */
+ Tcl_Config *configuration; /* Embedded configuration. */
+ CONST char *valEncoding; /* Name of the encoding used to store the
+ * configuration values, ASCII, thus UTF-8. */
{
- Tcl_Encoding venc = Tcl_GetEncoding (NULL, valEncoding);
- Tcl_Obj* pDB = GetConfigDict (interp);
- Tcl_Obj* pkg = Tcl_NewStringObj (pkgName, -1);
- Tcl_Obj* pkgDict;
- Tcl_DString cmdName;
- Tcl_Config* cfg;
- int res;
+ Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding);
+ Tcl_Obj *pDB = GetConfigDict(interp);
+ Tcl_Obj *pkg = Tcl_NewStringObj(pkgName, -1);
+ Tcl_Obj *pkgDict;
+ Tcl_DString cmdName;
+ Tcl_Config *cfg;
+ int res;
/*
- * Phase I: Adding the provided information to the internal
- * database of package meta data.
+ * Phase I: Adding the provided information to the internal database of
+ * package meta data.
*
- * Phase II: Create a command for querying this database, specific
- * to the package registerting its configuration. This is the
- * approved interface in TIP 59. In the future a more general
- * interface should be done, as followup to TIP 59. Simply because
- * our database is now general across packages, and not a
- * structure tied to one package.
+ * Phase II: Create a command for querying this database, specific to the
+ * package registerting its configuration. This is the approved interface
+ * in TIP 59. In the future a more general interface should be done, as
+ * followup to TIP 59. Simply because our database is now general across
+ * packages, and not a structure tied to one package.
+ *
+ * Note, the created command will have a reference through its clientdata.
*/
- /* Note, the created command will have a reference through its clientdata */
- Tcl_IncrRefCount (pkg);
+ Tcl_IncrRefCount(pkg);
- /* Retrieve package specific configuration ... */
+ /*
+ * Retrieve package specific configuration...
+ */
- res = Tcl_DictObjGet (interp, pDB, pkg, &pkgDict);
+ res = Tcl_DictObjGet(interp, pDB, pkg, &pkgDict);
if ((TCL_OK != res) || (pkgDict == NULL)) {
- pkgDict = Tcl_NewDictObj ();
- } else if (Tcl_IsShared (pkgDict)) {
- pkgDict = Tcl_DuplicateObj (pkgDict);
+ pkgDict = Tcl_NewDictObj();
+ } else if (Tcl_IsShared(pkgDict)) {
+ pkgDict = Tcl_DuplicateObj(pkgDict);
}
- /* Extend the package configuration ... */
-
- for (cfg = configuration;
- (cfg->key != (CONST char*) NULL) && (cfg->key [0] != '\0') ;
- cfg++) {
+ /*
+ * Extend the package configuration...
+ */
+ for (cfg=configuration ; (cfg->key!=NULL) && (cfg->key[0]!='\0') ; cfg++) {
Tcl_DString conv;
- CONST char* convValue = Tcl_ExternalToUtfDString (venc, cfg->value, -1, &conv);
+ CONST char *convValue =
+ Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv);
/*
* We know that the keys are in ASCII/UTF-8, so for them is no
* conversion required.
*/
- Tcl_DictObjPut (interp, pkgDict,
- Tcl_NewStringObj (cfg->key, -1),
- Tcl_NewStringObj (convValue, -1));
- Tcl_DStringFree (&conv);
+ Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
+ Tcl_NewStringObj(convValue, -1));
+ Tcl_DStringFree(&conv);
}
- /* Write the changes back into the overall database */
+ /*
+ * Write the changes back into the overall database.
+ */
- Tcl_DictObjPut (interp, pDB, pkg, pkgDict);
+ Tcl_DictObjPut(interp, pDB, pkg, pkgDict);
/*
* Now create the interface command for retrieval of the package
* information.
*/
- Tcl_DStringInit (&cmdName);
- Tcl_DStringAppend (&cmdName, "::", -1);
- Tcl_DStringAppend (&cmdName, pkgName, -1);
+ Tcl_DStringInit(&cmdName);
+ Tcl_DStringAppend(&cmdName, "::", -1);
+ Tcl_DStringAppend(&cmdName, pkgName, -1);
- /* The incomplete command name is the name of the namespace to
- * place it in.
+ /*
+ * The incomplete command name is the name of the namespace to place it
+ * in.
*/
- if ((Tcl_Namespace*) NULL == Tcl_FindNamespace(interp,
- Tcl_DStringValue (&cmdName), NULL, TCL_GLOBAL_ONLY)) {
-
- if ((Tcl_Namespace*) NULL == Tcl_CreateNamespace (interp,
- Tcl_DStringValue (&cmdName), (ClientData) NULL,
- (Tcl_NamespaceDeleteProc *) NULL)) {
-
- Tcl_Panic ("%s.\n%s %s", Tcl_GetStringResult(interp),
+ if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL,
+ TCL_GLOBAL_ONLY) == NULL) {
+ if (Tcl_CreateNamespace(interp, Tcl_DStringValue(&cmdName),
+ (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL) == NULL) {
+ Tcl_Panic("%s.\n%s %s", Tcl_GetStringResult(interp),
"Tcl_RegisterConfig: Unable to create namespace for",
"package configuration.");
}
}
- Tcl_DStringAppend (&cmdName, "::pkgconfig", -1);
+ Tcl_DStringAppend(&cmdName, "::pkgconfig", -1);
- if ((Tcl_Command) NULL == Tcl_CreateObjCommand (interp,
- Tcl_DStringValue (&cmdName), QueryConfigObjCmd,
- (ClientData) pkg, QueryConfigDelete)) {
-
- Tcl_Panic ("%s %s", "Tcl_RegisterConfig: Unable to create query",
+ if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName),
+ QueryConfigObjCmd, (ClientData) pkg, QueryConfigDelete) == NULL) {
+ Tcl_Panic("%s %s", "Tcl_RegisterConfig: Unable to create query",
"command for package configuration");
}
- Tcl_DStringFree (&cmdName);
+ Tcl_DStringFree(&cmdName);
}
/*
@@ -190,16 +181,14 @@ Tcl_RegisterConfig (interp, pkgName, configuration, valEncoding)
static int
QueryConfigObjCmd(clientData, interp, objc, objv)
- ClientData clientData;
- Tcl_Interp *interp;
- int objc;
- struct Tcl_Obj * CONST *objv;
+ ClientData clientData;
+ Tcl_Interp *interp;
+ int objc;
+ struct Tcl_Obj * CONST *objv;
{
- Tcl_Obj *pkgName = (Tcl_Obj*) clientData;
+ Tcl_Obj *pkgName = (Tcl_Obj *) clientData;
Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
- Tcl_DictSearch s;
- int n, i, res, done, index;
- Tcl_Obj *key, **vals;
+ int n, i, res, index;
static CONST char *subcmdStrings[] = {
"get", "list", NULL
@@ -212,15 +201,19 @@ QueryConfigObjCmd(clientData, interp, objc, objv)
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument?");
return TCL_ERROR;
}
- if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings,
- "subcommand", 0, &index) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0,
+ &index) != TCL_OK) {
return TCL_ERROR;
}
pDB = GetConfigDict(interp);
res = Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict);
if (res!=TCL_OK || pkgDict==NULL) {
- /* Maybe a Tcl_Panic is better, because the package data has to be present */
+ /*
+ * Maybe a Tcl_Panic is better, because the package data has to be
+ * present.
+ */
+
Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
return TCL_ERROR;
}
@@ -249,16 +242,19 @@ QueryConfigObjCmd(clientData, interp, objc, objv)
Tcl_DictObjSize(interp, pkgDict, &n);
listPtr = Tcl_NewListObj(n, NULL);
-
+
if (!listPtr) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("insufficient memory to create list", -1));
+ Tcl_NewStringObj("insufficient memory to create list",-1));
return TCL_ERROR;
}
-
+
if (n) {
- List *listRepPtr =
- (List *) listPtr->internalRep.twoPtrValue.ptr1;
+ List *listRepPtr = (List *)
+ listPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_DictSearch s;
+ Tcl_Obj *key, **vals;
+ int done;
listRepPtr->elemCount = n;
vals = &listRepPtr->elements;
@@ -285,7 +281,7 @@ QueryConfigObjCmd(clientData, interp, objc, objv)
*
* QueryConfigDelete --
*
- * Command delete procedure. Cleans up after the configuration query
+ * Command delete function. Cleans up after the configuration query
* command when it is deleted by the user or during finalization.
*
* Results:
@@ -298,11 +294,11 @@ QueryConfigObjCmd(clientData, interp, objc, objv)
*/
static void
-QueryConfigDelete (clientData)
- ClientData clientData;
+QueryConfigDelete(clientData)
+ ClientData clientData;
{
- Tcl_Obj* pkgName = (Tcl_Obj*) clientData;
- Tcl_DecrRefCount (pkgName);
+ Tcl_Obj *pkgName = (Tcl_Obj *) clientData;
+ Tcl_DecrRefCount(pkgName);
}
/*
@@ -322,19 +318,19 @@ QueryConfigDelete (clientData)
*-------------------------------------------------------------------------
*/
-static Tcl_Obj*
-GetConfigDict (interp)
- Tcl_Interp* interp;
+static Tcl_Obj *
+GetConfigDict(interp)
+ Tcl_Interp *interp;
{
- Tcl_Obj* pDB = Tcl_GetAssocData (interp, ASSOC_KEY, NULL);
+ Tcl_Obj *pDB = Tcl_GetAssocData(interp, ASSOC_KEY, NULL);
- if (pDB == (Tcl_Obj*) NULL) {
- pDB = Tcl_NewDictObj ();
- Tcl_IncrRefCount (pDB);
- Tcl_SetAssocData (interp, ASSOC_KEY, ConfigDictDeleteProc, pDB);
- }
+ if (pDB == (Tcl_Obj *) NULL) {
+ pDB = Tcl_NewDictObj();
+ Tcl_IncrRefCount(pDB);
+ Tcl_SetAssocData(interp, ASSOC_KEY, ConfigDictDeleteProc, pDB);
+ }
- return pDB;
+ return pDB;
}
/*
@@ -342,10 +338,10 @@ GetConfigDict (interp)
*
* ConfigDictDeleteProc --
*
- * This procedure is associated with the "Package About dict" assoc data
- * for an interpreter; it is invoked when the interpreter is
- * deleted in order to free the information assoicated with any
- * pending error reports.
+ * This function is associated with the "Package About dict" assoc data
+ * for an interpreter; it is invoked when the interpreter is deleted in
+ * order to free the information assoicated with any pending error
+ * reports.
*
* Results:
* None.
@@ -361,6 +357,14 @@ ConfigDictDeleteProc(clientData, interp)
ClientData clientData; /* Pointer to Tcl_Obj. */
Tcl_Interp *interp; /* Interpreter being deleted. */
{
- Tcl_Obj* pDB = (Tcl_Obj*) clientData;
- Tcl_DecrRefCount (pDB);
+ Tcl_Obj *pDB = (Tcl_Obj *) clientData;
+ Tcl_DecrRefCount(pDB);
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index d5e7005..3c79e85 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -1,25 +1,25 @@
/*
* tclFCmd.c
*
- * This file implements the generic portion of file manipulation
- * subcommands of the "file" command.
+ * This file implements the generic portion of file manipulation
+ * subcommands of the "file" command.
*
* Copyright (c) 1996-1998 Sun Microsystems, Inc.
*
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclFCmd.c,v 1.34 2005/06/13 08:32:05 vincentdarley Exp $
+ * RCS: @(#) $Id: tclFCmd.c,v 1.35 2005/07/24 22:56:43 dkf Exp $
*/
#include "tclInt.h"
/*
- * Declarations for local procedures defined in this file:
+ * Declarations for local functions defined in this file:
*/
static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr,
+ Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr,
int copyFlag, int force));
static Tcl_Obj * FileBasename _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr));
@@ -33,10 +33,10 @@ static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp,
*
* TclFileRenameCmd
*
- * This procedure implements the "rename" subcommand of the "file"
- * command. Filename arguments need to be translated to native
- * format before being passed to platform-specific code that
- * implements rename functionality.
+ * This function implements the "rename" subcommand of the "file"
+ * command. Filename arguments need to be translated to native format
+ * before being passed to platform-specific code that implements rename
+ * functionality.
*
* Results:
* A standard Tcl result.
@@ -61,10 +61,9 @@ TclFileRenameCmd(interp, objc, objv)
*
* TclFileCopyCmd
*
- * This procedure implements the "copy" subcommand of the "file"
- * command. Filename arguments need to be translated to native
- * format before being passed to platform-specific code that
- * implements copy functionality.
+ * This function implements the "copy" subcommand of the "file" command.
+ * Filename arguments need to be translated to native format before being
+ * passed to platform-specific code that implements copy functionality.
*
* Results:
* A standard Tcl result.
@@ -89,8 +88,8 @@ TclFileCopyCmd(interp, objc, objv)
*
* FileCopyRename --
*
- * Performs the work of TclFileRenameCmd and TclFileCopyCmd.
- * See comments for those procedures.
+ * Performs the work of TclFileRenameCmd and TclFileCopyCmd. See
+ * comments for those functions.
*
* Results:
* See above.
@@ -106,11 +105,11 @@ FileCopyRename(interp, objc, objv, copyFlag)
Tcl_Interp *interp; /* Used for error reporting. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
- int copyFlag; /* If non-zero, copy source(s). Otherwise,
+ int copyFlag; /* If non-zero, copy source(s). Otherwise,
* rename them. */
{
int i, result, force;
- Tcl_StatBuf statBuf;
+ Tcl_StatBuf statBuf;
Tcl_Obj *target;
i = FileForceOption(interp, objc - 2, objv + 2, &force);
@@ -119,9 +118,9 @@ FileCopyRename(interp, objc, objv, copyFlag)
}
i += 2;
if ((objc - i) < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]),
- " ?options? source ?source ...? target\"",
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ TclGetString(objv[0]), " ", TclGetString(objv[1]),
+ " ?options? source ?source ...? target\"",
(char *) NULL);
return TCL_ERROR;
}
@@ -151,14 +150,14 @@ FileCopyRename(interp, objc, objv, copyFlag)
Tcl_PosixError(interp);
Tcl_AppendResult(interp, "error ",
((copyFlag) ? "copying" : "renaming"), ": target \"",
- Tcl_GetString(target), "\" is not a directory",
+ TclGetString(target), "\" is not a directory",
(char *) NULL);
result = TCL_ERROR;
} else {
/*
- * Even though already have target == translated(objv[i+1]),
- * pass the original argument down, so if there's an error, the
- * error message will reflect the original arguments.
+ * Even though already have target == translated(objv[i+1]), pass
+ * the original argument down, so if there's an error, the error
+ * message will reflect the original arguments.
*/
result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag,
@@ -166,17 +165,17 @@ FileCopyRename(interp, objc, objv, copyFlag)
}
return result;
}
-
+
/*
- * Move each source file into target directory. Extract the basename
- * from each source, and append it to the end of the target path.
+ * Move each source file into target directory. Extract the basename from
+ * each source, and append it to the end of the target path.
*/
- for ( ; i < objc - 1; i++) {
+ for ( ; i<objc-1 ; i++) {
Tcl_Obj *jargv[2];
Tcl_Obj *source, *newFileName;
Tcl_Obj *temp;
-
+
source = FileBasename(interp, objv[i]);
if (source == NULL) {
result = TCL_ERROR;
@@ -205,10 +204,9 @@ FileCopyRename(interp, objc, objv, copyFlag)
*
* TclFileMakeDirsCmd
*
- * This procedure implements the "mkdir" subcommand of the "file"
- * command. Filename arguments need to be translated to native
- * format before being passed to platform-specific code that
- * implements mkdir functionality.
+ * This function implements the "mkdir" subcommand of the "file" command.
+ * Filename arguments need to be translated to native format before being
+ * passed to platform-specific code that implements mkdir functionality.
*
* Results:
* A standard Tcl result.
@@ -249,10 +247,10 @@ TclFileMakeDirsCmd(interp, objc, objv)
for (j = 0; j < pobjc; j++) {
target = Tcl_FSJoinPath(split, j + 1);
Tcl_IncrRefCount(target);
+
/*
- * Call Tcl_FSStat() so that if target is a symlink that
- * points to a directory we will create subdirectories in
- * that directory.
+ * Call Tcl_FSStat() so that if target is a symlink that points to
+ * a directory we will create subdirectories in that directory.
*/
if (Tcl_FSStat(target, &statBuf) == 0) {
@@ -262,26 +260,28 @@ TclFileMakeDirsCmd(interp, objc, objv)
goto done;
}
} else if (errno != ENOENT) {
- /*
- * If Tcl_FSStat() failed and the error is anything
- * other than non-existence of the target, throw the
- * error.
+ /*
+ * If Tcl_FSStat() failed and the error is anything other than
+ * non-existence of the target, throw the error.
*/
+
errfile = target;
goto done;
} else if (Tcl_FSCreateDirectory(target) != TCL_OK) {
- /*
+ /*
* Create might have failed because of being in a race
- * condition with another process trying to create the
- * same subdirectory.
+ * condition with another process trying to create the same
+ * subdirectory.
*/
+
if (errno == EEXIST) {
if ((Tcl_FSStat(target, &statBuf) == 0)
- && S_ISDIR(statBuf.st_mode)) {
- /*
- * It is a directory that wasn't there before,
- * so keep going without error.
+ && S_ISDIR(statBuf.st_mode)) {
+ /*
+ * It is a directory that wasn't there before, so keep
+ * going without error.
*/
+
Tcl_ResetResult(interp);
} else {
errfile = target;
@@ -292,19 +292,22 @@ TclFileMakeDirsCmd(interp, objc, objv)
goto done;
}
}
-
- /* Forget about this sub-path */
+
+ /*
+ * Forget about this sub-path.
+ */
+
Tcl_DecrRefCount(target);
target = NULL;
}
Tcl_DecrRefCount(split);
split = NULL;
}
-
- done:
+
+ done:
if (errfile != NULL) {
Tcl_AppendResult(interp, "can't create directory \"",
- Tcl_GetString(errfile), "\": ", Tcl_PosixError(interp),
+ TclGetString(errfile), "\": ", Tcl_PosixError(interp),
(char *) NULL);
result = TCL_ERROR;
}
@@ -322,8 +325,8 @@ TclFileMakeDirsCmd(interp, objc, objv)
*
* TclFileDeleteCmd
*
- * This procedure implements the "delete" subcommand of the "file"
- * command.
+ * This function implements the "delete" subcommand of the "file"
+ * command.
*
* Results:
* A standard Tcl result.
@@ -343,15 +346,15 @@ TclFileDeleteCmd(interp, objc, objv)
int i, force, result;
Tcl_Obj *errfile;
Tcl_Obj *errorBuffer = NULL;
-
+
i = FileForceOption(interp, objc - 2, objv + 2, &force);
if (i < 0) {
return TCL_ERROR;
}
i += 2;
if ((objc - i) < 1) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]),
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ TclGetString(objv[0]), " ", TclGetString(objv[1]),
" ?options? file ?file ...?\"", (char *) NULL);
return TCL_ERROR;
}
@@ -374,34 +377,39 @@ TclFileDeleteCmd(interp, objc, objv)
if (Tcl_FSLstat(objv[i], &statBuf) != 0) {
/*
- * Trying to delete a file that does not exist is not
- * considered an error, just a no-op
+ * Trying to delete a file that does not exist is not considered
+ * an error, just a no-op
*/
if (errno != ENOENT) {
result = TCL_ERROR;
}
} else if (S_ISDIR(statBuf.st_mode)) {
- /*
- * We own a reference count on errorBuffer, if it was set
- * as a result of this call.
+ /*
+ * We own a reference count on errorBuffer, if it was set as a
+ * result of this call.
*/
+
result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
if (result != TCL_OK) {
if ((force == 0) && (errno == EEXIST)) {
- Tcl_AppendResult(interp, "error deleting \"",
- Tcl_GetString(objv[i]),
- "\": directory not empty", (char *) NULL);
+ Tcl_AppendResult(interp, "error deleting \"",
+ TclGetString(objv[i]), "\": directory not empty",
+ (char *) NULL);
Tcl_PosixError(interp);
goto done;
}
- /*
+ /*
* If possible, use the untranslated name for the file.
*/
-
+
errfile = errorBuffer;
- /* FS supposed to check between translated objv and errfile */
+
+ /*
+ * FS supposed to check between translated objv and errfile.
+ */
+
if (Tcl_FSEqualPaths(objv[i], errfile)) {
errfile = objv[i];
}
@@ -409,32 +417,34 @@ TclFileDeleteCmd(interp, objc, objv)
} else {
result = Tcl_FSDeleteFile(objv[i]);
}
-
+
if (result != TCL_OK) {
result = TCL_ERROR;
- /*
- * It is important that we break on error, otherwise we
- * might end up owning reference counts on numerous
- * errorBuffers.
+
+ /*
+ * It is important that we break on error, otherwise we might end
+ * up owning reference counts on numerous errorBuffers.
*/
+
break;
}
}
if (result != TCL_OK) {
if (errfile == NULL) {
- /*
- * We try to accomodate poor error results from our
- * Tcl_FS calls
+ /*
+ * We try to accomodate poor error results from our Tcl_FS calls.
*/
- Tcl_AppendResult(interp, "error deleting unknown file: ",
+
+ Tcl_AppendResult(interp, "error deleting unknown file: ",
Tcl_PosixError(interp), (char *) NULL);
} else {
- Tcl_AppendResult(interp, "error deleting \"",
- Tcl_GetString(errfile), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_AppendResult(interp, "error deleting \"",
+ TclGetString(errfile), "\": ", Tcl_PosixError(interp),
+ (char *) NULL);
}
- }
- done:
+ }
+
+ done:
if (errorBuffer != NULL) {
Tcl_DecrRefCount(errorBuffer);
}
@@ -446,37 +456,37 @@ TclFileDeleteCmd(interp, objc, objv)
*
* CopyRenameOneFile
*
- * Copies or renames specified source file or directory hierarchy
- * to the specified target.
+ * Copies or renames specified source file or directory hierarchy to the
+ * specified target.
*
* Results:
* A standard Tcl result.
*
* Side effects:
- * Target is overwritten if the force flag is set. Attempting to
- * copy/rename a file onto a directory or a directory onto a file
- * will always result in an error.
+ * Target is overwritten if the force flag is set. Attempting to
+ * copy/rename a file onto a directory or a directory onto a file will
+ * always result in an error.
*
*----------------------------------------------------------------------
*/
static int
-CopyRenameOneFile(interp, source, target, copyFlag, force)
+CopyRenameOneFile(interp, source, target, copyFlag, force)
Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Obj *source; /* Pathname of file to copy. May need to
- * be translated. */
- Tcl_Obj *target; /* Pathname of file to create/overwrite.
- * May need to be translated. */
- int copyFlag; /* If non-zero, copy files. Otherwise,
- * rename them. */
+ Tcl_Obj *source; /* Pathname of file to copy. May need to be
+ * translated. */
+ Tcl_Obj *target; /* Pathname of file to create/overwrite. May
+ * need to be translated. */
+ int copyFlag; /* If non-zero, copy files. Otherwise, rename
+ * them. */
int force; /* If non-zero, overwrite target file if it
- * exists. Otherwise, error if target already
+ * exists. Otherwise, error if target already
* exists. */
{
int result;
Tcl_Obj *errfile, *errorBuffer;
- /* If source is a link, then this is the real file/directory */
- Tcl_Obj *actualSource = NULL;
+ Tcl_Obj *actualSource=NULL; /* If source is a link, then this is the real
+ * file/directory. */
Tcl_StatBuf sourceStatBuf, targetStatBuf;
if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
@@ -485,16 +495,15 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
return TCL_ERROR;
}
-
+
errfile = NULL;
errorBuffer = NULL;
result = TCL_ERROR;
-
+
/*
- * We want to copy/rename links and not the files they point to, so we
- * use lstat(). If target is a link, we also want to replace the
- * link and not the file it points to, so we also use lstat() on the
- * target.
+ * We want to copy/rename links and not the files they point to, so we use
+ * lstat(). If target is a link, we also want to replace the link and not
+ * the file it points to, so we also use lstat() on the target.
*/
if (Tcl_FSLstat(source, &sourceStatBuf) != 0) {
@@ -513,52 +522,52 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
goto done;
}
- /*
- * Prevent copying or renaming a file onto itself. Under Windows,
- * stat always returns 0 for st_ino. However, the Windows-specific
- * code knows how to deal with copying or renaming a file on top of
- * itself. It might be a good idea to write a stat that worked.
- */
-
- if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) {
- if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
- (sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
- result = TCL_OK;
- goto done;
- }
- }
+ /*
+ * Prevent copying or renaming a file onto itself. Under Windows, stat
+ * always returns 0 for st_ino. However, the Windows-specific code
+ * knows how to deal with copying or renaming a file on top of itself.
+ * It might be a good idea to write a stat that worked.
+ */
+
+ if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) {
+ if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
+ (sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
+ result = TCL_OK;
+ goto done;
+ }
+ }
/*
- * Prevent copying/renaming a file onto a directory and
- * vice-versa. This is a policy decision based on the fact that
- * existing implementations of copy and rename on all platforms
- * also prevent this.
+ * Prevent copying/renaming a file onto a directory and vice-versa.
+ * This is a policy decision based on the fact that existing
+ * implementations of copy and rename on all platforms also prevent
+ * this.
*/
if (S_ISDIR(sourceStatBuf.st_mode)
- && !S_ISDIR(targetStatBuf.st_mode)) {
+ && !S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
- Tcl_AppendResult(interp, "can't overwrite file \"",
- Tcl_GetString(target), "\" with directory \"",
- Tcl_GetString(source), "\"", (char *) NULL);
+ Tcl_AppendResult(interp, "can't overwrite file \"",
+ TclGetString(target), "\" with directory \"",
+ TclGetString(source), "\"", (char *) NULL);
goto done;
}
if (!S_ISDIR(sourceStatBuf.st_mode)
- && S_ISDIR(targetStatBuf.st_mode)) {
+ && S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
- Tcl_AppendResult(interp, "can't overwrite directory \"",
- Tcl_GetString(target), "\" with file \"",
- Tcl_GetString(source), "\"", (char *) NULL);
+ Tcl_AppendResult(interp, "can't overwrite directory \"",
+ TclGetString(target), "\" with file \"",
+ TclGetString(source), "\"", (char *) NULL);
goto done;
}
-
- /*
- * The destination exists, but appears to be ok to over-write,
- * and -force is given. We now try to adjust permissions to
- * ensure the operation succeeds. If we can't adjust
- * permissions, we'll let the actual copy/rename return
- * an error later.
+
+ /*
+ * The destination exists, but appears to be ok to over-write, and
+ * -force is given. We now try to adjust permissions to ensure the
+ * operation succeeds. If we can't adjust permissions, we'll let the
+ * actual copy/rename return an error later.
*/
+
{
Tcl_Obj* perm = Tcl_NewStringObj("u+w",-1);
int index;
@@ -575,68 +584,76 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
if (result == TCL_OK) {
goto done;
}
-
+
if (errno == EINVAL) {
- Tcl_AppendResult(interp, "error renaming \"",
- Tcl_GetString(source), "\" to \"",
- Tcl_GetString(target), "\": trying to rename a volume or ",
+ Tcl_AppendResult(interp, "error renaming \"",
+ TclGetString(source), "\" to \"", TclGetString(target),
+ "\": trying to rename a volume or ",
"move a directory into itself", (char *) NULL);
goto done;
} else if (errno != EXDEV) {
errfile = target;
goto done;
}
-
+
/*
- * The rename failed because the move was across file systems.
- * Fall through to copy file and then remove original. Note that
- * the low-level Tcl_FSRenameFileProc in the filesystem is allowed
- * to implement cross-filesystem moves itself, if it desires.
+ * The rename failed because the move was across file systems. Fall
+ * through to copy file and then remove original. Note that the
+ * low-level Tcl_FSRenameFileProc in the filesystem is allowed to
+ * implement cross-filesystem moves itself, if it desires.
*/
}
actualSource = source;
Tcl_IncrRefCount(actualSource);
- /*
- * Activate the following block to copy files instead of links.
- * However Tcl's semantics currently say we should copy links, so
- * any such change should be the subject of careful study on
- * the consequences.
- *
- * Perhaps there could be an optional flag to 'file copy' to
- * dictate which approach to use, with the default being _not_
- * to have this block active.
+
+ /*
+ * Activate the following block to copy files instead of links. However
+ * Tcl's semantics currently say we should copy links, so any such change
+ * should be the subject of careful study on the consequences.
+ *
+ * Perhaps there could be an optional flag to 'file copy' to dictate which
+ * approach to use, with the default being _not_ to have this block
+ * active.
*/
+
#if 0
#ifdef S_ISLNK
if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) {
- /*
- * We want to copy files not links. Therefore we must follow the
- * link. There are two purposes to this 'stat' call here. First
- * we want to know if the linked-file/dir actually exists, and
- * second, in the block of code which follows, some 20 lines
- * down, we want to check if the thing is a file or directory.
+ /*
+ * We want to copy files not links. Therefore we must follow the link.
+ * There are two purposes to this 'stat' call here. First we want to
+ * know if the linked-file/dir actually exists, and second, in the
+ * block of code which follows, some 20 lines down, we want to check
+ * if the thing is a file or directory.
*/
+
if (Tcl_FSStat(source, &sourceStatBuf) != 0) {
- /* Actual file doesn't exist */
- Tcl_AppendResult(interp,
- "error copying \"", Tcl_GetString(source),
+ /*
+ * Actual file doesn't exist.
+ */
+
+ Tcl_AppendResult(interp, "error copying \"", TclGetString(source),
"\": the target of this link doesn't exist",
(char *) NULL);
goto done;
} else {
int counter = 0;
+
while (1) {
Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0);
if (path == NULL) {
break;
}
- /*
- * Now we want to check if this is a relative path,
- * and if so, to make it absolute
+
+ /*
+ * Now we want to check if this is a relative path, and if so,
+ * to make it absolute.
*/
+
if (Tcl_FSGetPathType(path) == TCL_PATH_RELATIVE) {
Tcl_Obj *abs = Tcl_FSJoinToPath(actualSource, 1, &path);
+
if (abs == NULL) {
break;
}
@@ -647,9 +664,16 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
Tcl_DecrRefCount(actualSource);
actualSource = path;
counter++;
- /* Arbitrary limit of 20 links to follow */
+
+ /*
+ * Arbitrary limit of 20 links to follow.
+ */
+
if (counter > 20) {
- /* Too many links */
+ /*
+ * Too many links.
+ */
+
Tcl_SetErrno(EMLINK);
errfile = source;
goto done;
@@ -665,33 +689,34 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer);
if (result != TCL_OK) {
if (errno == EXDEV) {
- /*
+ /*
* The copy failed because we're trying to do a
- * cross-filesystem copy. We do this through our Tcl
- * library.
+ * cross-filesystem copy. We do this through our Tcl library.
*/
+
Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL);
Tcl_IncrRefCount(copyCommand);
- Tcl_ListObjAppendElement(interp, copyCommand,
+ Tcl_ListObjAppendElement(interp, copyCommand,
Tcl_NewStringObj("::tcl::CopyDirectory",-1));
if (copyFlag) {
- Tcl_ListObjAppendElement(interp, copyCommand,
- Tcl_NewStringObj("copying",-1));
+ Tcl_ListObjAppendElement(interp, copyCommand,
+ Tcl_NewStringObj("copying",-1));
} else {
- Tcl_ListObjAppendElement(interp, copyCommand,
- Tcl_NewStringObj("renaming",-1));
+ Tcl_ListObjAppendElement(interp, copyCommand,
+ Tcl_NewStringObj("renaming",-1));
}
Tcl_ListObjAppendElement(interp, copyCommand, source);
Tcl_ListObjAppendElement(interp, copyCommand, target);
- result = Tcl_EvalObjEx(interp, copyCommand,
- TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
+ result = Tcl_EvalObjEx(interp, copyCommand,
+ TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
Tcl_DecrRefCount(copyCommand);
if (result != TCL_OK) {
- /*
- * There was an error in the Tcl-level copy.
- * We will pass on the Tcl error message and
- * can ensure this by setting errfile to NULL
+ /*
+ * There was an error in the Tcl-level copy. We will pass
+ * on the Tcl error message and can ensure this by setting
+ * errfile to NULL
*/
+
errfile = NULL;
}
} else {
@@ -709,19 +734,22 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
result = TclCrossFilesystemCopy(interp, source, target);
}
if (result != TCL_OK) {
- /*
- * We could examine 'errno' to double-check if the problem
- * was with the target, but we checked the source above,
- * so it should be quite clear
+ /*
+ * We could examine 'errno' to double-check if the problem was
+ * with the target, but we checked the source above, so it should
+ * be quite clear
*/
+
errfile = target;
- /*
- * We now need to reset the result, because the above call,
- * if it failed, may have put an error message in place.
- * (Ideally we would prefer not to pass an interpreter in
- * above, but the channel IO code used by
- * TclCrossFilesystemCopy currently requires one)
+
+ /*
+ * We now need to reset the result, because the above call, if it
+ * failed, may have put an error message in place. (Ideally we
+ * would prefer not to pass an interpreter in above, but the
+ * channel IO code used by TclCrossFilesystemCopy currently
+ * requires one).
*/
+
Tcl_ResetResult(interp);
}
}
@@ -740,31 +768,30 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
}
}
if (result != TCL_OK) {
- Tcl_AppendResult(interp, "can't unlink \"",
- Tcl_GetString(errfile), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_AppendResult(interp, "can't unlink \"", TclGetString(errfile),
+ "\": ", Tcl_PosixError(interp), (char *) NULL);
errfile = NULL;
}
}
-
- done:
+
+ done:
if (errfile != NULL) {
- Tcl_AppendResult(interp,
+ Tcl_AppendResult(interp,
((copyFlag) ? "error copying \"" : "error renaming \""),
- Tcl_GetString(source), (char *) NULL);
+ TclGetString(source), (char *) NULL);
if (errfile != source) {
- Tcl_AppendResult(interp, "\" to \"", Tcl_GetString(target),
- (char *) NULL);
+ Tcl_AppendResult(interp, "\" to \"", TclGetString(target),
+ (char *) NULL);
if (errfile != target) {
- Tcl_AppendResult(interp, "\": \"", Tcl_GetString(errfile),
- (char *) NULL);
+ Tcl_AppendResult(interp, "\": \"", TclGetString(errfile),
+ (char *) NULL);
}
}
Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
(char *) NULL);
}
if (errorBuffer != NULL) {
- Tcl_DecrRefCount(errorBuffer);
+ Tcl_DecrRefCount(errorBuffer);
}
if (actualSource != NULL) {
Tcl_DecrRefCount(actualSource);
@@ -777,14 +804,13 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
*
* FileForceOption --
*
- * Helps parse command line options for file commands that take
- * the "-force" and "--" options.
+ * Helps parse command line options for file commands that take the
+ * "-force" and "--" options.
*
* Results:
- * The return value is how many arguments from argv were consumed
- * by this function, or -1 if there was an error parsing the
- * options. If an error occurred, an error message is left in the
- * interp's result.
+ * The return value is how many arguments from argv were consumed by this
+ * function, or -1 if there was an error parsing the options. If an error
+ * occurred, an error message is left in the interp's result.
*
* Side effects:
* None.
@@ -798,23 +824,23 @@ FileForceOption(interp, objc, objv, forcePtr)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument strings. First command line
* option, if it exists, begins at 0. */
- int *forcePtr; /* If the "-force" was specified, *forcePtr
- * is filled with 1, otherwise with 0. */
+ int *forcePtr; /* If the "-force" was specified, *forcePtr is
+ * filled with 1, otherwise with 0. */
{
int force, i;
-
+
force = 0;
for (i = 0; i < objc; i++) {
- if (Tcl_GetString(objv[i])[0] != '-') {
+ if (TclGetString(objv[i])[0] != '-') {
break;
}
- if (strcmp(Tcl_GetString(objv[i]), "-force") == 0) {
+ if (strcmp(TclGetString(objv[i]), "-force") == 0) {
force = 1;
- } else if (strcmp(Tcl_GetString(objv[i]), "--") == 0) {
+ } else if (strcmp(TclGetString(objv[i]), "--") == 0) {
i++;
break;
} else {
- Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[i]),
+ Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]),
"\": should be -force or --", (char *)NULL);
return -1;
}
@@ -829,13 +855,12 @@ FileForceOption(interp, objc, objv, forcePtr)
*
* Given a path in either tcl format (with / separators), or in the
* platform-specific format for the current platform, return all the
- * characters in the path after the last directory separator. But,
- * if path is the root directory, returns no characters.
+ * characters in the path after the last directory separator. But, if
+ * path is the root directory, returns no characters.
*
* Results:
- * Returns the string object that represents the basename. If there
- * is an error, an error message is left in interp, and NULL is
- * returned.
+ * Returns the string object that represents the basename. If there is an
+ * error, an error message is left in interp, and NULL is returned.
*
* Side effects:
* None.
@@ -851,12 +876,12 @@ FileBasename(interp, pathPtr)
int objc;
Tcl_Obj *splitPtr;
Tcl_Obj *resultPtr = NULL;
-
+
splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
Tcl_IncrRefCount(splitPtr);
-
+
if (objc != 0) {
- if ((objc == 1) && (*Tcl_GetString(pathPtr) == '~')) {
+ if ((objc == 1) && (*TclGetString(pathPtr) == '~')) {
Tcl_DecrRefCount(splitPtr);
if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
return NULL;
@@ -873,7 +898,7 @@ FileBasename(interp, pathPtr)
if (objc > 0) {
Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr);
if ((objc == 1) &&
- (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
+ (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
resultPtr = NULL;
}
}
@@ -891,33 +916,31 @@ FileBasename(interp, pathPtr)
*
* TclFileAttrsCmd --
*
- * Sets or gets the platform-specific attributes of a file. The
- * objc-objv points to the file name with the rest of the command
- * line following. This routine uses platform-specific tables of
- * option strings and callbacks. The callback to get the
- * attributes take three parameters:
- * Tcl_Interp *interp; The interp to report errors with.
- * Since this is an object-based API,
- * the object form of the result should
- * be used.
+ * Sets or gets the platform-specific attributes of a file. The objc-objv
+ * points to the file name with the rest of the command line following.
+ * This routine uses platform-specific tables of option strings and
+ * callbacks. The callback to get the attributes take three parameters:
+ * Tcl_Interp *interp; The interp to report errors with. Since
+ * this is an object-based API, the object
+ * form of the result should be used.
* CONST char *fileName; This is extracted using
* Tcl_TranslateFileName.
- * TclObj **attrObjPtrPtr; A new object to hold the attribute
- * is allocated and put here.
+ * TclObj **attrObjPtrPtr; A new object to hold the attribute is
+ * allocated and put here.
* The first two parameters of the callback used to write out the
* attributes are the same. The third parameter is:
- * CONST *attrObjPtr; A pointer to the object that has
- * the new attribute.
- * They both return standard TCL errors; if the routine to get
- * an attribute fails, no object is allocated and *attrObjPtrPtr
- * is unchanged.
+ * CONST *attrObjPtr; A pointer to the object that has the new
+ * attribute.
+ * They both return standard TCL errors; if the routine to get an
+ * attribute fails, no object is allocated and *attrObjPtrPtr is
+ * unchanged.
*
* Results:
- * Standard TCL error.
+ * Standard TCL error.
*
* Side effects:
- * May set file attributes for the file name.
- *
+ * May set file attributes for the file name.
+ *
*----------------------------------------------------------------------
*/
@@ -932,7 +955,7 @@ TclFileAttrsCmd(interp, objc, objv)
Tcl_Obj* objStrings = NULL;
int numObjStrings = -1;
Tcl_Obj *filePtr;
-
+
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv,
"name ?option? ?value? ?option value ...?");
@@ -943,39 +966,49 @@ TclFileAttrsCmd(interp, objc, objv)
if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
return TCL_ERROR;
}
-
+
objc -= 3;
objv += 3;
result = TCL_ERROR;
Tcl_SetErrno(0);
+
attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
if (attributeStrings == NULL) {
int index;
Tcl_Obj *objPtr;
+
if (objStrings == NULL) {
if (Tcl_GetErrno() != 0) {
- /*
- * There was an error, probably that the filePtr is
- * not accepted by any filesystem
+ /*
+ * There was an error, probably that the filePtr is not
+ * accepted by any filesystem
*/
Tcl_AppendResult(interp, "could not read \"",
- Tcl_GetString(filePtr), "\": ", Tcl_PosixError(interp),
+ TclGetString(filePtr), "\": ", Tcl_PosixError(interp),
(char *) NULL);
return TCL_ERROR;
}
goto end;
}
- /* We own the object now */
+
+ /*
+ * We own the object now.
+ */
+
Tcl_IncrRefCount(objStrings);
- /* Use objStrings as a list object */
+
+ /*
+ * Use objStrings as a list object.
+ */
+
if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
goto end;
}
attributeStrings = (CONST char **)
- ckalloc ((1+numObjStrings) * sizeof(char*));
+ ckalloc((1+numObjStrings) * sizeof(char*));
for (index = 0; index < numObjStrings; index++) {
Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
- attributeStrings[index] = Tcl_GetString(objPtr);
+ attributeStrings[index] = TclGetString(objPtr);
}
attributeStrings[index] = NULL;
}
@@ -986,28 +1019,39 @@ TclFileAttrsCmd(interp, objc, objv)
int index, res = TCL_OK, nbAtts = 0;
Tcl_Obj *listPtr;
-
+
listPtr = Tcl_NewListObj(0, NULL);
for (index = 0; attributeStrings[index] != NULL; index++) {
Tcl_Obj *objPtrAttr;
-
+
if (res != TCL_OK) {
- /* Clear the error from the last iteration */
- Tcl_ResetResult(interp);
+ /*
+ * Clear the error from the last iteration.
+ */
+
+ Tcl_ResetResult(interp);
}
+
res = Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtrAttr);
if (res == TCL_OK) {
- Tcl_Obj *objPtr = Tcl_NewStringObj(attributeStrings[index], -1);
- Tcl_ListObjAppendElement(interp, listPtr, objPtr);
- Tcl_ListObjAppendElement(interp, listPtr, objPtrAttr);
- nbAtts++;
+ Tcl_Obj *objPtr =
+ Tcl_NewStringObj(attributeStrings[index], -1);
+
+ Tcl_ListObjAppendElement(interp, listPtr, objPtr);
+ Tcl_ListObjAppendElement(interp, listPtr, objPtrAttr);
+ nbAtts++;
}
}
+
if (index > 0 && nbAtts == 0) {
- /* Error: no valid attributes found */
+ /*
+ * Error: no valid attributes found.
+ */
+
Tcl_DecrRefCount(listPtr);
goto end;
}
+
Tcl_SetObjResult(interp, listPtr);
} else if (objc == 1) {
/*
@@ -1018,9 +1062,9 @@ TclFileAttrsCmd(interp, objc, objv)
Tcl_Obj *objPtr = NULL;
if (numObjStrings == 0) {
- Tcl_AppendResult(interp, "bad option \"",
- Tcl_GetString(objv[0]), "\", there are no file attributes"
- " in this filesystem.", (char *) NULL);
+ Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
+ "\", there are no file attributes in this filesystem.",
+ (char *) NULL);
goto end;
}
@@ -1039,11 +1083,11 @@ TclFileAttrsCmd(interp, objc, objv)
*/
int i, index;
-
+
if (numObjStrings == 0) {
- Tcl_AppendResult(interp, "bad option \"",
- Tcl_GetString(objv[0]), "\", there are no file attributes"
- " in this filesystem.", (char *) NULL);
+ Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
+ "\", there are no file attributes in this filesystem.",
+ (char *) NULL);
goto end;
}
@@ -1054,8 +1098,7 @@ TclFileAttrsCmd(interp, objc, objv)
}
if (i + 1 == objc) {
Tcl_AppendResult(interp, "value for \"",
- Tcl_GetString(objv[i]), "\" missing",
- (char *) NULL);
+ TclGetString(objv[i]), "\" missing", (char *) NULL);
goto end;
}
if (Tcl_FSFileAttrsSet(interp, index, filePtr,
@@ -1066,17 +1109,29 @@ TclFileAttrsCmd(interp, objc, objv)
}
result = TCL_OK;
- end:
+ end:
if (numObjStrings != -1) {
- /* Free up the array we allocated */
+ /*
+ * Free up the array we allocated.
+ */
+
ckfree((char*)attributeStrings);
- /*
- * We don't need this object that was passed to us
- * any more.
+
+ /*
+ * We don't need this object that was passed to us any more.
*/
+
if (objStrings != NULL) {
Tcl_DecrRefCount(objStrings);
}
}
return result;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclGet.c b/generic/tclGet.c
index be3d942..b28b3f92 100644
--- a/generic/tclGet.c
+++ b/generic/tclGet.c
@@ -1,17 +1,17 @@
-/*
+/*
* tclGet.c --
*
- * This file contains procedures to convert strings into
- * other forms, like integers or floating-point numbers or
- * booleans, doing syntax checking along the way.
+ * This file contains functions to convert strings into other forms, like
+ * integers or floating-point numbers or booleans, doing syntax checking
+ * along the way.
*
* Copyright (c) 1990-1993 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
*
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclGet.c,v 1.15 2005/05/10 18:34:38 kennykb Exp $
+ * RCS: @(#) $Id: tclGet.c,v 1.16 2005/07/24 22:56:43 dkf Exp $
*/
#include "tclInt.h"
@@ -25,10 +25,10 @@
* Given a string, produce the corresponding integer value.
*
* Results:
- * The return value is normally TCL_OK; in this case *intPtr
- * will be set to the integer value equivalent to src. If
- * src is improperly formed then TCL_ERROR is returned and
- * an error message will be left in the interp's result.
+ * The return value is normally TCL_OK; in this case *intPtr will be set
+ * to the integer value equivalent to src. If src is improperly formed
+ * then TCL_ERROR is returned and an error message will be left in the
+ * interp's result.
*
* Side effects:
* None.
@@ -45,7 +45,7 @@ Tcl_GetInt(interp, src, intPtr)
{
Tcl_Obj obj;
int code;
-
+
obj.refCount = 1;
obj.bytes = (char *) src;
obj.length = strlen(src);
@@ -63,16 +63,15 @@ Tcl_GetInt(interp, src, intPtr)
*
* TclGetLong --
*
- * Given a string, produce the corresponding long integer value.
- * This routine is a version of Tcl_GetInt but returns a "long"
- * instead of an "int".
+ * Given a string, produce the corresponding long integer value. This
+ * routine is a version of Tcl_GetInt but returns a "long" instead of an
+ * "int" (a difference that matters on 64-bit architectures).
*
* Results:
- * The return value is normally TCL_OK; in this case *longPtr
- * will be set to the long integer value equivalent to src. If
- * src is improperly formed then TCL_ERROR is returned and
- * an error message will be left in the interp's result if interp
- * is non-NULL.
+ * The return value is normally TCL_OK; in this case *longPtr will be set
+ * to the long integer value equivalent to src. If src is improperly
+ * formed then TCL_ERROR is returned and an error message will be left in
+ * the interp's result if interp is non-NULL.
*
* Side effects:
* None.
@@ -82,11 +81,10 @@ Tcl_GetInt(interp, src, intPtr)
int
TclGetLong(interp, src, longPtr)
- Tcl_Interp *interp; /* Interpreter used for error reporting
- * if not NULL. */
- CONST char *src; /* String containing a (possibly signed)
- * long integer in a form acceptable to
- * strtoul. */
+ Tcl_Interp *interp; /* Interpreter used for error reporting if not
+ * NULL. */
+ CONST char *src; /* String containing a (possibly signed) long
+ * integer in a form acceptable to strtoul. */
long *longPtr; /* Place to store converted long result. */
{
Tcl_Obj obj;
@@ -113,10 +111,10 @@ TclGetLong(interp, src, longPtr)
* floating-point value.
*
* Results:
- * The return value is normally TCL_OK; in this case *doublePtr
- * will be set to the double-precision value equivalent to src.
- * If src is improperly formed then TCL_ERROR is returned and
- * an error message will be left in the interp's result.
+ * The return value is normally TCL_OK; in this case *doublePtr will be
+ * set to the double-precision value equivalent to src. If src is
+ * improperly formed then TCL_ERROR is returned and an error message will
+ * be left in the interp's result.
*
* Side effects:
* None.
@@ -151,14 +149,14 @@ Tcl_GetDouble(interp, src, doublePtr)
*
* Tcl_GetBoolean --
*
- * Given a string, return a 0/1 boolean value corresponding
- * to the string.
+ * Given a string, return a 0/1 boolean value corresponding to the
+ * string.
*
* Results:
- * The return value is normally TCL_OK; in this case *boolPtr
- * will be set to the 0/1 value equivalent to src. If
- * src is improperly formed then TCL_ERROR is returned and
- * an error message will be left in the interp's result.
+ * The return value is normally TCL_OK; in this case *boolPtr will be set
+ * to the 0/1 value equivalent to src. If src is improperly formed then
+ * TCL_ERROR is returned and an error message will be left in the
+ * interp's result.
*
* Side effects:
* None.
@@ -172,8 +170,8 @@ Tcl_GetBoolean(interp, src, boolPtr)
CONST char *src; /* String containing a boolean number
* specified either as 1/0 or true/false or
* yes/no. */
- int *boolPtr; /* Place to store converted result, which
- * will be 0 or 1. */
+ int *boolPtr; /* Place to store converted result, which will
+ * be 0 or 1. */
{
Tcl_Obj obj;
int code;
@@ -192,3 +190,11 @@ Tcl_GetBoolean(interp, src, boolPtr)
}
return code;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c
index cea5725..8281bc4 100644
--- a/generic/tclPreserve.c
+++ b/generic/tclPreserve.c
@@ -1,71 +1,73 @@
-/*
+/*
* tclPreserve.c --
*
- * This file contains a collection of procedures that are used
- * to make sure that widget records and other data structures
- * aren't reallocated when there are nested procedures that
- * depend on their existence.
+ * This file contains a collection of functions that are used to make
+ * sure that widget records and other data structures aren't reallocated
+ * when there are nested functions that depend on their existence.
*
* Copyright (c) 1991-1994 The Regents of the University of California.
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
*
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclPreserve.c,v 1.6 2005/06/24 20:07:22 kennykb Exp $
+ * RCS: @(#) $Id: tclPreserve.c,v 1.7 2005/07/24 22:56:43 dkf Exp $
*/
#include "tclInt.h"
/*
- * The following data structure is used to keep track of all the
- * Tcl_Preserve calls that are still in effect. It grows as needed
- * to accommodate any number of calls in effect.
+ * The following data structure is used to keep track of all the Tcl_Preserve
+ * calls that are still in effect. It grows as needed to accommodate any
+ * number of calls in effect.
*/
typedef struct {
ClientData clientData; /* Address of preserved block. */
- int refCount; /* Number of Tcl_Preserve calls in effect
- * for block. */
+ int refCount; /* Number of Tcl_Preserve calls in effect for
+ * block. */
int mustFree; /* Non-zero means Tcl_EventuallyFree was
* called while a Tcl_Preserve call was in
- * effect, so the structure must be freed
- * when refCount becomes zero. */
- Tcl_FreeProc *freeProc; /* Procedure to call to free. */
+ * effect, so the structure must be freed when
+ * refCount becomes zero. */
+ Tcl_FreeProc *freeProc; /* Function to call to free. */
} Reference;
+/*
+ * Global data structures used to hold the list of preserved data references.
+ * These variables are protected by "preserveMutex".
+ */
+
static Reference *refArray; /* First in array of references. */
-static int spaceAvl = 0; /* Total number of structures available
- * at *firstRefPtr. */
-static int inUse = 0; /* Count of structures currently in use
- * in refArray. */
-#define INITIAL_SIZE 2
+static int spaceAvl = 0; /* Total number of structures available at
+ * *firstRefPtr. */
+static int inUse = 0; /* Count of structures currently in use in
+ * refArray. */
TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */
+#define INITIAL_SIZE 2 /* Initial number of reference slots to make */
+
/*
- * The following data structure is used to keep track of whether an
- * arbitrary block of memory has been deleted. This is used by the
- * TclHandle code to avoid the more time-expensive algorithm of
- * Tcl_Preserve(). This mechanism is mainly used when we have lots of
- * references to a few big, expensive objects that we don't want to live
- * any longer than necessary.
+ * The following data structure is used to keep track of whether an arbitrary
+ * block of memory has been deleted. This is used by the TclHandle code to
+ * avoid the more time-expensive algorithm of Tcl_Preserve(). This mechanism
+ * is mainly used when we have lots of references to a few big, expensive
+ * objects that we don't want to live any longer than necessary.
*/
typedef struct HandleStruct {
- VOID *ptr; /* Pointer to the memory block being
- * tracked. This field will become NULL when
- * the memory block is deleted. This field
- * must be the first in the structure. */
+ VOID *ptr; /* Pointer to the memory block being tracked.
+ * This field will become NULL when the memory
+ * block is deleted. This field must be the
+ * first in the structure. */
#ifdef TCL_MEM_DEBUG
- VOID *ptr2; /* Backup copy of the abpve pointer used to
+ VOID *ptr2; /* Backup copy of the above pointer used to
* ensure that the contents of the handle are
* not changed by anyone else. */
#endif
int refCount; /* Number of TclHandlePreserve() calls in
* effect on this handle. */
} HandleStruct;
-
-
/*
*----------------------------------------------------------------------
@@ -102,16 +104,16 @@ TclFinalizePreserve()
*
* Tcl_Preserve --
*
- * This procedure is used by a procedure to declare its interest
- * in a particular block of memory, so that the block will not be
- * reallocated until a matching call to Tcl_Release has been made.
+ * This function is used by a function to declare its interest in a
+ * particular block of memory, so that the block will not be reallocated
+ * until a matching call to Tcl_Release has been made.
*
* Results:
* None.
*
* Side effects:
- * Information is retained so that the block of memory will
- * not be freed until at least the matching call to Tcl_Release.
+ * Information is retained so that the block of memory will not be freed
+ * until at least the matching call to Tcl_Release.
*
*----------------------------------------------------------------------
*/
@@ -124,12 +126,12 @@ Tcl_Preserve(clientData)
int i;
/*
- * See if there is already a reference for this pointer. If so,
- * just increment its reference count.
+ * See if there is already a reference for this pointer. If so, just
+ * increment its reference count.
*/
Tcl_MutexLock(&preserveMutex);
- for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
+ for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) {
if (refPtr->clientData == clientData) {
refPtr->refCount++;
Tcl_MutexUnlock(&preserveMutex);
@@ -138,8 +140,8 @@ Tcl_Preserve(clientData)
}
/*
- * Make a reference array if it doesn't already exist, or make it
- * bigger if it is full.
+ * Make a reference array if it doesn't already exist, or make it bigger
+ * if it is full.
*/
if (inUse == spaceAvl) {
@@ -178,17 +180,16 @@ Tcl_Preserve(clientData)
*
* Tcl_Release --
*
- * This procedure is called to cancel a previous call to
- * Tcl_Preserve, thereby allowing a block of memory to be
- * freed (if no one else cares about it).
+ * This function is called to cancel a previous call to Tcl_Preserve,
+ * thereby allowing a block of memory to be freed (if no one else cares
+ * about it).
*
* Results:
* None.
*
* Side effects:
- * If Tcl_EventuallyFree has been called for clientData, and if
- * no other call to Tcl_Preserve is still in effect, the block of
- * memory is freed.
+ * If Tcl_EventuallyFree has been called for clientData, and if no other
+ * call to Tcl_Preserve is still in effect, the block of memory is freed.
*
*----------------------------------------------------------------------
*/
@@ -198,48 +199,57 @@ Tcl_Release(clientData)
ClientData clientData; /* Pointer to malloc'ed block of memory. */
{
Reference *refPtr;
- int mustFree;
- Tcl_FreeProc *freeProc;
int i;
Tcl_MutexLock(&preserveMutex);
- for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
+ for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) {
+ int mustFree;
+ Tcl_FreeProc *freeProc;
+
if (refPtr->clientData != clientData) {
continue;
}
- refPtr->refCount--;
- if (refPtr->refCount == 0) {
-
- /*
- * Must remove information from the slot before calling freeProc
- * to avoid reentrancy problems if the freeProc calls Tcl_Preserve
- * on the same clientData. Copy down the last reference in the
- * array to overwrite the current slot.
- */
-
- freeProc = refPtr->freeProc;
- mustFree = refPtr->mustFree;
- inUse--;
- if (i < inUse) {
- refArray[i] = refArray[inUse];
- }
- if (mustFree) {
- if (freeProc == TCL_DYNAMIC) {
- ckfree((char *) clientData);
- } else {
- Tcl_MutexUnlock(&preserveMutex);
- (*freeProc)((char *) clientData);
- return;
- }
- }
+
+ if (--refPtr->refCount != 0) {
+ Tcl_MutexUnlock(&preserveMutex);
+ return;
+ }
+
+ /*
+ * Must remove information from the slot before calling freeProc to
+ * avoid reentrancy problems if the freeProc calls Tcl_Preserve on the
+ * same clientData. Copy down the last reference in the array to
+ * overwrite the current slot.
+ */
+
+ freeProc = refPtr->freeProc;
+ mustFree = refPtr->mustFree;
+ inUse--;
+ if (i < inUse) {
+ refArray[i] = refArray[inUse];
}
+
+ /*
+ * Now committed to disposing the data. But first, we've patched up
+ * all the global data structures so we should release the mutex now.
+ * Only then should we dabble around with potentially-slow memory
+ * managers...
+ */
+
Tcl_MutexUnlock(&preserveMutex);
+ if (mustFree) {
+ if (freeProc == TCL_DYNAMIC) {
+ ckfree((char *) clientData);
+ } else {
+ (*freeProc)((char *) clientData);
+ }
+ }
return;
}
Tcl_MutexUnlock(&preserveMutex);
/*
- * Reference not found. This is a bug in the caller.
+ * Reference not found. This is a bug in the caller.
*/
Tcl_Panic("Tcl_Release couldn't find reference for 0x%x", clientData);
@@ -250,10 +260,9 @@ Tcl_Release(clientData)
*
* Tcl_EventuallyFree --
*
- * Free up a block of memory, unless a call to Tcl_Preserve is in
- * effect for that block. In this case, defer the free until all
- * calls to Tcl_Preserve have been undone by matching calls to
- * Tcl_Release.
+ * Free up a block of memory, unless a call to Tcl_Preserve is in effect
+ * for that block. In this case, defer the free until all calls to
+ * Tcl_Preserve have been undone by matching calls to Tcl_Release.
*
* Results:
* None.
@@ -267,14 +276,14 @@ Tcl_Release(clientData)
void
Tcl_EventuallyFree(clientData, freeProc)
ClientData clientData; /* Pointer to malloc'ed block of memory. */
- Tcl_FreeProc *freeProc; /* Procedure to actually do free. */
+ Tcl_FreeProc *freeProc; /* Function to actually do free. */
{
Reference *refPtr;
int i;
/*
- * See if there is a reference for this pointer. If so, set its
- * "mustFree" flag (the flag had better not be set already!).
+ * See if there is a reference for this pointer. If so, set its "mustFree"
+ * flag (the flag had better not be set already!).
*/
Tcl_MutexLock(&preserveMutex);
@@ -283,7 +292,8 @@ Tcl_EventuallyFree(clientData, freeProc)
continue;
}
if (refPtr->mustFree) {
- Tcl_Panic("Tcl_EventuallyFree called twice for 0x%x\n", clientData);
+ Tcl_Panic("Tcl_EventuallyFree called twice for 0x%x\n",
+ clientData);
}
refPtr->mustFree = 1;
refPtr->freeProc = freeProc;
@@ -308,31 +318,29 @@ Tcl_EventuallyFree(clientData, freeProc)
*
* TclHandleCreate --
*
- * Allocate a handle that contains enough information to determine
- * if an arbitrary malloc'd block has been deleted. This is
- * used to avoid the more time-expensive algorithm of Tcl_Preserve().
+ * Allocate a handle that contains enough information to determine if an
+ * arbitrary malloc'd block has been deleted. This is used to avoid the
+ * more time-expensive algorithm of Tcl_Preserve().
*
* Results:
* The return value is a TclHandle that refers to the given malloc'd
- * block. Doubly dereferencing the returned handle will give
- * back the pointer to the block, or will give NULL if the block has
- * been deleted.
+ * block. Doubly dereferencing the returned handle will give back the
+ * pointer to the block, or will give NULL if the block has been deleted.
*
* Side effects:
- * The caller must keep track of this handle (generally by storing
- * it in a field in the malloc'd block) and call TclHandleFree()
- * on this handle when the block is deleted. Everything else that
- * wishes to keep track of whether the malloc'd block has been deleted
- * should use calls to TclHandlePreserve() and TclHandleRelease()
- * on the associated handle.
+ * The caller must keep track of this handle (generally by storing it in
+ * a field in the malloc'd block) and call TclHandleFree() on this handle
+ * when the block is deleted. Everything else that wishes to keep track
+ * of whether the malloc'd block has been deleted should use calls to
+ * TclHandlePreserve() and TclHandleRelease() on the associated handle.
*
*---------------------------------------------------------------------------
*/
TclHandle
TclHandleCreate(ptr)
- VOID *ptr; /* Pointer to an arbitrary block of memory
- * to be tracked for deletion. Must not be
+ VOID *ptr; /* Pointer to an arbitrary block of memory to
+ * be tracked for deletion. Must not be
* NULL. */
{
HandleStruct *handlePtr;
@@ -351,11 +359,10 @@ TclHandleCreate(ptr)
*
* TclHandleFree --
*
- * Called when the arbitrary malloc'd block associated with the
- * handle is being deleted. Modifies the handle so that doubly
- * dereferencing it will give NULL. This informs any user of the
- * handle that the block of memory formerly referenced by the
- * handle has been freed.
+ * Called when the arbitrary malloc'd block associated with the handle is
+ * being deleted. Modifies the handle so that doubly dereferencing it
+ * will give NULL. This informs any user of the handle that the block of
+ * memory formerly referenced by the handle has been freed.
*
* Results:
* None.
@@ -368,10 +375,10 @@ TclHandleCreate(ptr)
void
TclHandleFree(handle)
- TclHandle handle; /* Previously created handle associated
- * with a malloc'd block that is being
- * deleted. The handle is modified so that
- * doubly dereferencing it will give NULL. */
+ TclHandle handle; /* Previously created handle associated with a
+ * malloc'd block that is being deleted. The
+ * handle is modified so that doubly
+ * dereferencing it will give NULL. */
{
HandleStruct *handlePtr;
@@ -396,25 +403,25 @@ TclHandleFree(handle)
*
* TclHandlePreserve --
*
- * Declare an interest in the arbitrary malloc'd block associated
- * with the handle.
+ * Declare an interest in the arbitrary malloc'd block associated with
+ * the handle.
*
* Results:
* The return value is the handle argument, with its ref count
* incremented.
*
* Side effects:
- * For each call to TclHandlePreserve(), there should be a matching
- * call to TclHandleRelease() when the caller is no longer interested
- * in the malloc'd block associated with the handle.
+ * For each call to TclHandlePreserve(), there should be a matching call
+ * to TclHandleRelease() when the caller is no longer interested in the
+ * malloc'd block associated with the handle.
*
*---------------------------------------------------------------------------
*/
TclHandle
TclHandlePreserve(handle)
- TclHandle handle; /* Declare an interest in the block of
- * memory referenced by this handle. */
+ TclHandle handle; /* Declare an interest in the block of memory
+ * referenced by this handle. */
{
HandleStruct *handlePtr;
@@ -423,8 +430,7 @@ TclHandlePreserve(handle)
if (handlePtr->refCount == 0x61616161) {
Tcl_Panic("using previously disposed TclHandle %x", handlePtr);
}
- if ((handlePtr->ptr != NULL)
- && (handlePtr->ptr != handlePtr->ptr2)) {
+ if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) {
Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x",
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
@@ -439,24 +445,24 @@ TclHandlePreserve(handle)
*
* TclHandleRelease --
*
- * This procedure is called to release an interest in the malloc'd
- * block associated with the handle.
+ * This function is called to release an interest in the malloc'd block
+ * associated with the handle.
*
* Results:
* None.
*
* Side effects:
- * The ref count of the handle is decremented. If the malloc'd block
- * has been freed and if no one is using the handle any more, the
- * handle will be reclaimed.
+ * The ref count of the handle is decremented. If the malloc'd block has
+ * been freed and if no one is using the handle any more, the handle will
+ * be reclaimed.
*
*---------------------------------------------------------------------------
*/
-
+
void
TclHandleRelease(handle)
- TclHandle handle; /* Unregister interest in the block of
- * memory referenced by this handle. */
+ TclHandle handle; /* Unregister interest in the block of memory
+ * referenced by this handle. */
{
HandleStruct *handlePtr;
@@ -465,8 +471,7 @@ TclHandleRelease(handle)
if (handlePtr->refCount == 0x61616161) {
Tcl_Panic("using previously disposed TclHandle %x", handlePtr);
}
- if ((handlePtr->ptr != NULL)
- && (handlePtr->ptr != handlePtr->ptr2)) {
+ if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) {
Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x",
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
@@ -476,4 +481,11 @@ TclHandleRelease(handle)
ckfree((char *) handlePtr);
}
}
-
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 1266191..a575a40 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -1,64 +1,65 @@
-/*
+/*
* tclResult.c --
*
* This file contains code to manage the interpreter result.
*
* Copyright (c) 1997 by Sun Microsystems, Inc.
*
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclResult.c,v 1.28 2005/06/02 03:11:38 dgp Exp $
+ * RCS: @(#) $Id: tclResult.c,v 1.29 2005/07/24 22:56:43 dkf Exp $
*/
#include "tclInt.h"
-/* Indices of the standard return options dictionary keys */
+/*
+ * Indices of the standard return options dictionary keys.
+ */
+
enum returnKeys {
KEY_CODE, KEY_ERRORCODE, KEY_ERRORINFO, KEY_ERRORLINE,
KEY_LEVEL, KEY_OPTIONS, KEY_LAST
};
/*
- * Function prototypes for local procedures in this file:
+ * Function prototypes for local functions in this file:
*/
-static Tcl_Obj ** GetKeys();
+static Tcl_Obj ** GetKeys _ANSI_ARGS_((void));
static void ReleaseKeys _ANSI_ARGS_((ClientData clientData));
-static void ResetObjResult _ANSI_ARGS_((Interp *iPtr));
+static void ResetObjResult _ANSI_ARGS_((Interp *iPtr));
static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
int newSpace));
/*
- * This structure is used to take a snapshot of the interpreter
- * state in Tcl_SaveInterpState. You can snapshot the state,
- * execute a command, and then back up to the result or the
- * error that was previously in progress.
+ * This structure is used to take a snapshot of the interpreter state in
+ * Tcl_SaveInterpState. You can snapshot the state, execute a command, and
+ * then back up to the result or the error that was previously in progress.
*/
+
typedef struct InterpState {
int status; /* return code status */
- int flags; /* Each remaining field saves */
- int returnLevel; /* the corresponding field of */
- int returnCode; /* the Interp struct. These */
- Tcl_Obj *errorInfo; /* fields take together are the */
- Tcl_Obj *errorCode; /* "state" of the interp. */
+ int flags; /* Each remaining field saves the */
+ int returnLevel; /* corresponding field of the Interp */
+ int returnCode; /* struct. These fields taken together are */
+ Tcl_Obj *errorInfo; /* the "state" of the interp. */
+ Tcl_Obj *errorCode;
Tcl_Obj *returnOpts;
Tcl_Obj *objResult;
} InterpState;
-
/*
*----------------------------------------------------------------------
*
* Tcl_SaveInterpState --
*
- * Fills a token with a snapshot of the current state of the
- * interpreter. The snapshot can be restored at any point by
- * TclRestoreInterpState.
+ * Fills a token with a snapshot of the current state of the interpreter.
+ * The snapshot can be restored at any point by TclRestoreInterpState.
*
- * The token returned must be eventally passed to one of the
- * routines TclRestoreInterpState or TclDiscardInterpState,
- * or there will be a memory leak.
+ * The token returned must be eventally passed to one of the routines
+ * TclRestoreInterpState or TclDiscardInterpState, or there will be a
+ * memory leak.
*
* Results:
* Returns a token representing the interp state.
@@ -71,8 +72,8 @@ typedef struct InterpState {
Tcl_InterpState
Tcl_SaveInterpState(interp, status)
- Tcl_Interp* interp; /* Interpreter's state to be saved */
- int status; /* status code for current operation */
+ Tcl_Interp* interp; /* Interpreter's state to be saved */
+ int status; /* status code for current operation */
{
Interp *iPtr = (Interp *)interp;
InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState));
@@ -103,9 +104,9 @@ Tcl_SaveInterpState(interp, status)
*
* Tcl_RestoreInterpState --
*
- * Accepts an interp and a token previously returned by
- * Tcl_SaveInterpState. Restore the state of the interp
- * to what it was at the time of the Tcl_SaveInterpState call.
+ * Accepts an interp and a token previously returned by
+ * Tcl_SaveInterpState. Restore the state of the interp to what it was at
+ * the time of the Tcl_SaveInterpState call.
*
* Results:
* Returns the status value originally passed in to Tcl_SaveInterpState.
@@ -161,8 +162,8 @@ Tcl_RestoreInterpState(interp, state)
*
* Tcl_DiscardInterpState --
*
- * Accepts a token previously returned by Tcl_SaveInterpState.
- * Frees the memory it uses.
+ * Accepts a token previously returned by Tcl_SaveInterpState. Frees the
+ * memory it uses.
*
* Results:
* None.
@@ -180,13 +181,13 @@ Tcl_DiscardInterpState(state)
InterpState *statePtr = (InterpState *)state;
if (statePtr->errorInfo) {
- Tcl_DecrRefCount(statePtr->errorInfo);
+ Tcl_DecrRefCount(statePtr->errorInfo);
}
if (statePtr->errorCode) {
- Tcl_DecrRefCount(statePtr->errorCode);
+ Tcl_DecrRefCount(statePtr->errorCode);
}
if (statePtr->returnOpts) {
- Tcl_DecrRefCount(statePtr->returnOpts);
+ Tcl_DecrRefCount(statePtr->returnOpts);
}
Tcl_DecrRefCount(statePtr->objResult);
ckfree((char*) statePtr);
@@ -197,15 +198,13 @@ Tcl_DiscardInterpState(state)
*
* Tcl_SaveResult --
*
- * Takes a snapshot of the current result state of the interpreter.
- * The snapshot can be restored at any point by
- * Tcl_RestoreResult. Note that this routine does not
- * preserve the errorCode, errorInfo, or flags fields so it
- * should not be used if an error is in progress.
+ * Takes a snapshot of the current result state of the interpreter. The
+ * snapshot can be restored at any point by Tcl_RestoreResult. Note that
+ * this routine does not preserve the errorCode, errorInfo, or flags
+ * fields so it should not be used if an error is in progress.
*
- * Once a snapshot is saved, it must be restored by calling
- * Tcl_RestoreResult, or discarded by calling
- * Tcl_DiscardResult.
+ * Once a snapshot is saved, it must be restored by calling
+ * Tcl_RestoreResult, or discarded by calling Tcl_DiscardResult.
*
* Results:
* None.
@@ -224,17 +223,17 @@ Tcl_SaveResult(interp, statePtr)
Interp *iPtr = (Interp *) interp;
/*
- * Move the result object into the save state. Note that we don't need
- * to change its refcount because we're moving it, not adding a new
- * reference. Put an empty object into the interpreter.
+ * Move the result object into the save state. Note that we don't need to
+ * change its refcount because we're moving it, not adding a new
+ * reference. Put an empty object into the interpreter.
*/
statePtr->objResultPtr = iPtr->objResultPtr;
- iPtr->objResultPtr = Tcl_NewObj();
- Tcl_IncrRefCount(iPtr->objResultPtr);
+ iPtr->objResultPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(iPtr->objResultPtr);
/*
- * Save the string result.
+ * Save the string result.
*/
statePtr->freeProc = iPtr->freeProc;
@@ -277,15 +276,15 @@ Tcl_SaveResult(interp, statePtr)
*
* Tcl_RestoreResult --
*
- * Restores the state of the interpreter to a snapshot taken
- * by Tcl_SaveResult. After this call, the token for
- * the interpreter state is no longer valid.
+ * Restores the state of the interpreter to a snapshot taken by
+ * Tcl_SaveResult. After this call, the token for the interpreter state
+ * is no longer valid.
*
* Results:
- * None.
+ * None.
*
* Side effects:
- * Restores the interpreter result.
+ * Restores the interpreter result.
*
*----------------------------------------------------------------------
*/
@@ -345,16 +344,15 @@ Tcl_RestoreResult(interp, statePtr)
*
* Tcl_DiscardResult --
*
- * Frees the memory associated with an interpreter snapshot
- * taken by Tcl_SaveResult. If the snapshot is not
- * restored, this procedure must be called to discard it,
- * or the memory will be lost.
+ * Frees the memory associated with an interpreter snapshot taken by
+ * Tcl_SaveResult. If the snapshot is not restored, this function must be
+ * called to discard it, or the memory will be lost.
*
* Results:
- * None.
+ * None.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -387,8 +385,8 @@ Tcl_DiscardResult(statePtr)
* None.
*
* Side effects:
- * interp->result is left pointing either to "result"
- * or to a copy of it. Also, the object result is reset.
+ * interp->result is left pointing either to "result" or to a copy of it.
+ * Also, the object result is reset.
*
*----------------------------------------------------------------------
*/
@@ -397,11 +395,11 @@ void
Tcl_SetResult(interp, result, freeProc)
Tcl_Interp *interp; /* Interpreter with which to associate the
* return value. */
- register char *result; /* Value to be returned. If NULL, the
- * result is set to an empty string. */
+ register char *result; /* Value to be returned. If NULL, the result
+ * is set to an empty string. */
Tcl_FreeProc *freeProc; /* Gives information about the string:
- * TCL_STATIC, TCL_VOLATILE, or the address
- * of a Tcl_FreeProc such as free. */
+ * TCL_STATIC, TCL_VOLATILE, or the address of
+ * a Tcl_FreeProc such as free. */
{
Interp *iPtr = (Interp *) interp;
int length;
@@ -428,9 +426,9 @@ Tcl_SetResult(interp, result, freeProc)
}
/*
- * If the old result was dynamically-allocated, free it up. Do it
- * here, rather than at the beginning, in case the new result value
- * was part of the old result value.
+ * If the old result was dynamically-allocated, free it up. Do it here,
+ * rather than at the beginning, in case the new result value was part of
+ * the old result value.
*/
if (oldFreeProc != 0) {
@@ -467,16 +465,16 @@ Tcl_SetResult(interp, result, freeProc)
CONST char *
Tcl_GetStringResult(interp)
- register Tcl_Interp *interp; /* Interpreter whose result to return. */
+ register Tcl_Interp *interp;/* Interpreter whose result to return. */
{
/*
- * If the string result is empty, move the object result to the
- * string result, then reset the object result.
+ * If the string result is empty, move the object result to the string
+ * result, then reset the object result.
*/
-
+
if (*(interp->result) == 0) {
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
- TCL_VOLATILE);
+ TCL_VOLATILE);
}
return interp->result;
}
@@ -492,11 +490,10 @@ Tcl_GetStringResult(interp)
* None.
*
* Side effects:
- * interp->objResultPtr is left pointing to the object referenced
- * by objPtr. The object's reference count is incremented since
- * there is now a new reference to it. The reference count for any
- * old objResultPtr value is decremented. Also, the string result
- * is reset.
+ * interp->objResultPtr is left pointing to the object referenced by
+ * objPtr. The object's reference count is incremented since there is now
+ * a new reference to it. The reference count for any old objResultPtr
+ * value is decremented. Also, the string result is reset.
*
*----------------------------------------------------------------------
*/
@@ -505,9 +502,8 @@ void
Tcl_SetObjResult(interp, objPtr)
Tcl_Interp *interp; /* Interpreter with which to associate the
* return object value. */
- register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the
- * obj result is made an empty string
- * object. */
+ register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the obj
+ * result is made an empty string object. */
{
register Interp *iPtr = (Interp *) interp;
register Tcl_Obj *oldObjResult = iPtr->objResultPtr;
@@ -516,10 +512,10 @@ Tcl_SetObjResult(interp, objPtr)
Tcl_IncrRefCount(objPtr); /* since interp result is a reference */
/*
- * We wait until the end to release the old object result, in case
- * we are setting the result to itself.
+ * We wait until the end to release the old object result, in case we are
+ * setting the result to itself.
*/
-
+
TclDecrRefCount(oldObjResult);
/*
@@ -544,17 +540,17 @@ Tcl_SetObjResult(interp, objPtr)
* Tcl_GetObjResult --
*
* Returns an interpreter's result value as a Tcl object. The object's
- * reference count is not modified; the caller must do that if it
- * needs to hold on to a long-term reference to it.
+ * reference count is not modified; the caller must do that if it needs
+ * to hold on to a long-term reference to it.
*
* Results:
* The interpreter's result as an object.
*
* Side effects:
- * If the interpreter has a non-empty string result, the result object
- * is either empty or stale because some procedure set interp->result
- * directly. If so, the string result is moved to the result object
- * then the string result is reset.
+ * If the interpreter has a non-empty string result, the result object is
+ * either empty or stale because some function set interp->result
+ * directly. If so, the string result is moved to the result object then
+ * the string result is reset.
*
*----------------------------------------------------------------------
*/
@@ -568,17 +564,17 @@ Tcl_GetObjResult(interp)
int length;
/*
- * If the string result is non-empty, move the string result to the
- * object result, then reset the string result.
+ * If the string result is non-empty, move the string result to the object
+ * result, then reset the string result.
*/
-
+
if (*(iPtr->result) != 0) {
ResetObjResult(iPtr);
-
+
objResultPtr = iPtr->objResultPtr;
length = strlen(iPtr->result);
TclInitStringRep(objResultPtr, iPtr->result, length);
-
+
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
@@ -598,20 +594,17 @@ Tcl_GetObjResult(interp)
*
* Tcl_AppendResultVA --
*
- * Append a variable number of strings onto the interpreter's
- * result.
+ * Append a variable number of strings onto the interpreter's result.
*
* Results:
* None.
*
* Side effects:
- * The result of the interpreter given by the first argument is
- * extended by the strings in the va_list (up to a terminating
- * NULL argument).
+ * The result of the interpreter given by the first argument is extended
+ * by the strings in the va_list (up to a terminating NULL argument).
*
- * If the string result is non-empty, the object result forced to
- * be a duplicate of it first. There will be a string result
- * afterwards.
+ * If the string result is non-empty, the object result forced to be a
+ * duplicate of it first. There will be a string result afterwards.
*
*----------------------------------------------------------------------
*/
@@ -629,19 +622,19 @@ Tcl_AppendResultVA(interp, argList)
}
Tcl_AppendStringsToObjVA(objPtr, argList);
Tcl_SetObjResult(interp, objPtr);
+
/*
- * Strictly we should call Tcl_GetStringResult(interp) here to
- * make sure that interp->result is correct according to the old
- * contract, but that makes the performance of much code (e.g. in
- * Tk) absolutely awful. So we leave it out; code that really
- * wants interp->result can just insert the calls to
- * Tcl_GetStringResult() itself. [Patch 1041072 discussion]
+ * Strictly we should call Tcl_GetStringResult(interp) here to make sure
+ * that interp->result is correct according to the old contract, but that
+ * makes the performance of much code (e.g. in Tk) absolutely awful. So we
+ * leave it out; code that really wants interp->result can just insert the
+ * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion]
*/
#ifdef USE_DIRECT_INTERP_RESULT_ACCESS
/*
- * Ensure that the interp->result is legal so old Tcl 7.* code
- * still works. There's still embarrasingly much of it about...
+ * Ensure that the interp->result is legal so old Tcl 7.* code still
+ * works. There's still embarrasingly much of it about...
*/
(void) Tcl_GetStringResult(interp);
@@ -653,20 +646,18 @@ Tcl_AppendResultVA(interp, argList)
*
* Tcl_AppendResult --
*
- * Append a variable number of strings onto the interpreter's
- * result.
+ * Append a variable number of strings onto the interpreter's result.
*
* Results:
* None.
*
* Side effects:
- * The result of the interpreter given by the first argument is
- * extended by the strings given by the second and following
- * arguments (up to a terminating NULL argument).
+ * The result of the interpreter given by the first argument is extended
+ * by the strings given by the second and following arguments (up to a
+ * terminating NULL argument).
*
- * If the string result is non-empty, the object result forced to
- * be a duplicate of it first. There will be a string result
- * afterwards.
+ * If the string result is non-empty, the object result forced to be a
+ * duplicate of it first. There will be a string result afterwards.
*
*----------------------------------------------------------------------
*/
@@ -694,10 +685,10 @@ Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
* None.
*
* Side effects:
- * The result in the interpreter given by the first argument is
- * extended with a list element converted from string. A separator
- * space is added before the converted list element unless the current
- * result is empty, contains the single character "{", or ends in " {".
+ * The result in the interpreter given by the first argument is extended
+ * with a list element converted from string. A separator space is added
+ * before the converted list element unless the current result is empty,
+ * contains the single character "{", or ends in " {".
*
* If the string result is empty, the object result is moved to the
* string result, then the object result is reset.
@@ -709,8 +700,8 @@ void
Tcl_AppendElement(interp, element)
Tcl_Interp *interp; /* Interpreter whose result is to be
* extended. */
- CONST char *element; /* String to convert to list element and
- * add to result. */
+ CONST char *element; /* String to convert to list element and add
+ * to result. */
{
Interp *iPtr = (Interp *) interp;
char *dst;
@@ -718,27 +709,27 @@ Tcl_AppendElement(interp, element)
int flags;
/*
- * If the string result is empty, move the object result to the
- * string result, then reset the object result.
+ * If the string result is empty, move the object result to the string
+ * result, then reset the object result.
*/
(void) Tcl_GetStringResult(interp);
/*
- * See how much space is needed, and grow the append buffer if
- * needed to accommodate the list element.
+ * See how much space is needed, and grow the append buffer if needed to
+ * accommodate the list element.
*/
size = Tcl_ScanElement(element, &flags) + 1;
if ((iPtr->result != iPtr->appendResult)
|| (iPtr->appendResult[iPtr->appendUsed] != 0)
|| ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
- SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
+ SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
}
/*
- * Convert the string into a list element and copy it to the
- * buffer that's forming, with a space separator if needed.
+ * Convert the string into a list element and copy it to the buffer that's
+ * forming, with a space separator if needed.
*/
dst = iPtr->appendResult + iPtr->appendUsed;
@@ -746,11 +737,13 @@ Tcl_AppendElement(interp, element)
iPtr->appendUsed++;
*dst = ' ';
dst++;
+
/*
- * If we need a space to separate this element from preceding
- * stuff, then this element will not lead a list, and need not
- * have it's leading '#' quoted.
+ * If we need a space to separate this element from preceding stuff,
+ * then this element will not lead a list, and need not have it's
+ * leading '#' quoted.
*/
+
flags |= TCL_DONT_QUOTE_HASH;
}
iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags);
@@ -761,10 +754,10 @@ Tcl_AppendElement(interp, element)
*
* SetupAppendBuffer --
*
- * This procedure makes sure that there is an append buffer properly
- * initialized, if necessary, from the interpreter's result, and
- * that it has at least enough room to accommodate newSpace new
- * bytes of information.
+ * This function makes sure that there is an append buffer properly
+ * initialized, if necessary, from the interpreter's result, and that it
+ * has at least enough room to accommodate newSpace new bytes of
+ * information.
*
* Results:
* None.
@@ -778,8 +771,8 @@ Tcl_AppendElement(interp, element)
static void
SetupAppendBuffer(iPtr, newSpace)
Interp *iPtr; /* Interpreter whose result is being set up. */
- int newSpace; /* Make sure that at least this many bytes
- * of new information may be added. */
+ int newSpace; /* Make sure that at least this many bytes of
+ * new information may be added. */
{
int totalSpace;
@@ -791,9 +784,9 @@ SetupAppendBuffer(iPtr, newSpace)
if (iPtr->result != iPtr->appendResult) {
/*
- * If an oversized buffer was used recently, then free it up
- * so we go back to a smaller buffer. This avoids tying up
- * memory forever after a large operation.
+ * If an oversized buffer was used recently, then free it up so we go
+ * back to a smaller buffer. This avoids tying up memory forever after
+ * a large operation.
*/
if (iPtr->appendAvl > 500) {
@@ -805,13 +798,13 @@ SetupAppendBuffer(iPtr, newSpace)
} else if (iPtr->result[iPtr->appendUsed] != 0) {
/*
* Most likely someone has modified a result created by
- * Tcl_AppendResult et al. so that it has a different size.
- * Just recompute the size.
+ * Tcl_AppendResult et al. so that it has a different size. Just
+ * recompute the size.
*/
iPtr->appendUsed = strlen(iPtr->result);
}
-
+
totalSpace = newSpace + iPtr->appendUsed;
if (totalSpace >= iPtr->appendAvl) {
char *new;
@@ -831,7 +824,7 @@ SetupAppendBuffer(iPtr, newSpace)
} else if (iPtr->result != iPtr->appendResult) {
strcpy(iPtr->appendResult, iPtr->result);
}
-
+
Tcl_FreeResult((Tcl_Interp *) iPtr);
iPtr->result = iPtr->appendResult;
}
@@ -841,9 +834,9 @@ SetupAppendBuffer(iPtr, newSpace)
*
* Tcl_FreeResult --
*
- * This procedure frees up the memory associated with an interpreter's
+ * This function frees up the memory associated with an interpreter's
* string result. It also resets the interpreter's result object.
- * Tcl_FreeResult is most commonly used when a procedure is about to
+ * Tcl_FreeResult is most commonly used when a function is about to
* replace one result value with another.
*
* Results:
@@ -851,9 +844,9 @@ SetupAppendBuffer(iPtr, newSpace)
*
* Side effects:
* Frees the memory associated with interp's string result and sets
- * interp->freeProc to zero, but does not change interp->result or
- * clear error state. Resets interp's result object to an unshared
- * empty object.
+ * interp->freeProc to zero, but does not change interp->result or clear
+ * error state. Resets interp's result object to an unshared empty
+ * object.
*
*----------------------------------------------------------------------
*/
@@ -863,7 +856,7 @@ Tcl_FreeResult(interp)
register Tcl_Interp *interp; /* Interpreter for which to free result. */
{
register Interp *iPtr = (Interp *) interp;
-
+
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
@@ -872,7 +865,7 @@ Tcl_FreeResult(interp)
}
iPtr->freeProc = 0;
}
-
+
ResetObjResult(iPtr);
}
@@ -881,15 +874,14 @@ Tcl_FreeResult(interp)
*
* Tcl_ResetResult --
*
- * This procedure resets both the interpreter's string and object
- * results.
+ * This function resets both the interpreter's string and object results.
*
* Results:
* None.
*
* Side effects:
- * It resets the result object to an unshared empty object. It
- * then restores the interpreter's string result area to its default
+ * It resets the result object to an unshared empty object. It then
+ * restores the interpreter's string result area to its default
* initialized state, freeing up any memory that may have been
* allocated. It also clears any error information for the interpreter.
*
@@ -941,15 +933,15 @@ Tcl_ResetResult(interp)
*
* ResetObjResult --
*
- * Procedure used to reset an interpreter's Tcl result object.
+ * Function used to reset an interpreter's Tcl result object.
*
* Results:
* None.
*
* Side effects:
* Resets the interpreter's result object to an unshared empty string
- * object with ref count one. It does not clear any error information
- * in the interpreter.
+ * object with ref count one. It does not clear any error information in
+ * the interpreter.
*
*----------------------------------------------------------------------
*/
@@ -968,7 +960,7 @@ ResetObjResult(iPtr)
iPtr->objResultPtr = objResultPtr;
} else {
if ((objResultPtr->bytes != NULL)
- && (objResultPtr->bytes != tclEmptyStringRep)) {
+ && (objResultPtr->bytes != tclEmptyStringRep)) {
ckfree((char *) objResultPtr->bytes);
}
objResultPtr->bytes = tclEmptyStringRep;
@@ -983,30 +975,30 @@ ResetObjResult(iPtr)
*
* Tcl_SetErrorCodeVA --
*
- * This procedure is called to record machine-readable information
- * about an error that is about to be returned.
+ * This function is called to record machine-readable information about
+ * an error that is about to be returned.
*
* Results:
* None.
*
* Side effects:
* The errorCode field of the interp is modified to hold all of the
- * arguments to this procedure, in a list form with each argument
- * becoming one element of the list.
+ * arguments to this function, in a list form with each argument becoming
+ * one element of the list.
*
*----------------------------------------------------------------------
*/
void
-Tcl_SetErrorCodeVA (interp, argList)
+Tcl_SetErrorCodeVA(interp, argList)
Tcl_Interp *interp; /* Interpreter in which to set errorCode */
va_list argList; /* Variable argument list. */
{
Tcl_Obj *errorObj = Tcl_NewObj();
/*
- * Scan through the arguments one at a time, appending them to
- * the errorCode field as list elements.
+ * Scan through the arguments one at a time, appending them to the
+ * errorCode field as list elements.
*/
while (1) {
@@ -1024,19 +1016,20 @@ Tcl_SetErrorCodeVA (interp, argList)
*
* Tcl_SetErrorCode --
*
- * This procedure is called to record machine-readable information
- * about an error that is about to be returned.
+ * This function is called to record machine-readable information about
+ * an error that is about to be returned.
*
* Results:
* None.
*
* Side effects:
* The errorCode field of the interp is modified to hold all of the
- * arguments to this procedure, in a list form with each argument
- * becoming one element of the list.
+ * arguments to this function, in a list form with each argument becoming
+ * one element of the list.
*
*----------------------------------------------------------------------
*/
+
/* VARARGS2 */
void
Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
@@ -1045,8 +1038,8 @@ Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
va_list argList;
/*
- * Scan through the arguments one at a time, appending them to
- * the errorCode field as list elements.
+ * Scan through the arguments one at a time, appending them to the
+ * errorCode field as list elements.
*/
interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
@@ -1059,9 +1052,9 @@ Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
*
* Tcl_SetObjErrorCode --
*
- * This procedure is called to record machine-readable information
- * about an error that is about to be returned. The caller should
- * build a list object up and pass it to this routine.
+ * This function is called to record machine-readable information about
+ * an error that is about to be returned. The caller should build a list
+ * object up and pass it to this routine.
*
* Results:
* None.
@@ -1078,7 +1071,7 @@ Tcl_SetObjErrorCode(interp, errorObjPtr)
Tcl_Obj *errorObjPtr;
{
Interp *iPtr = (Interp *) interp;
-
+
if (iPtr->errorCode) {
Tcl_DecrRefCount(iPtr->errorCode);
}
@@ -1091,18 +1084,18 @@ Tcl_SetObjErrorCode(interp, errorObjPtr)
*
* GetKeys --
*
- * Returns a Tcl_Obj * array of the standard keys used in the
- * return options dictionary.
+ * Returns a Tcl_Obj * array of the standard keys used in the return
+ * options dictionary.
*
- * Broadly sharing one copy of these key values helps with both
- * memory efficiency and dictionary lookup times.
+ * Broadly sharing one copy of these key values helps with both memory
+ * efficiency and dictionary lookup times.
*
* Results:
* A Tcl_Obj * array.
*
* Side effects:
- * First time called in a thread, creates the keys (allocating
- * memory) and arranges for their cleanup at thread exit.
+ * First time called in a thread, creates the keys (allocating memory)
+ * and arranges for their cleanup at thread exit.
*
*----------------------------------------------------------------------
*/
@@ -1113,19 +1106,29 @@ GetKeys()
static Tcl_ThreadDataKey returnKeysKey;
Tcl_Obj **keys = Tcl_GetThreadData(&returnKeysKey,
(int) (KEY_LAST * sizeof(Tcl_Obj *)));
+
if (keys[0] == NULL) {
- /* First call in this thread, create the keys... */
+ /*
+ * First call in this thread, create the keys...
+ */
+
int i;
- keys[KEY_CODE] = Tcl_NewStringObj("-code", -1);
- keys[KEY_ERRORCODE] = Tcl_NewStringObj("-errorcode", -1);
- keys[KEY_ERRORINFO] = Tcl_NewStringObj("-errorinfo", -1);
- keys[KEY_ERRORLINE] = Tcl_NewStringObj("-errorline", -1);
- keys[KEY_LEVEL] = Tcl_NewStringObj("-level", -1);
- keys[KEY_OPTIONS] = Tcl_NewStringObj("-options", -1);
+
+ keys[KEY_CODE] = Tcl_NewStringObj("-code", -1);
+ keys[KEY_ERRORCODE] = Tcl_NewStringObj("-errorcode", -1);
+ keys[KEY_ERRORINFO] = Tcl_NewStringObj("-errorinfo", -1);
+ keys[KEY_ERRORLINE] = Tcl_NewStringObj("-errorline", -1);
+ keys[KEY_LEVEL] = Tcl_NewStringObj("-level", -1);
+ keys[KEY_OPTIONS] = Tcl_NewStringObj("-options", -1);
+
for (i = KEY_CODE; i < KEY_LAST; i++) {
Tcl_IncrRefCount(keys[i]);
}
- /* ... and arrange for their clenaup. */
+
+ /*
+ * ... and arrange for their clenaup.
+ */
+
Tcl_CreateThreadExitHandler(ReleaseKeys, (ClientData) keys);
}
return keys;
@@ -1136,8 +1139,8 @@ GetKeys()
*
* ReleaseKeys --
*
- * Called as a thread exit handler to cleanup return options
- * dictionary keys.
+ * Called as a thread exit handler to cleanup return options dictionary
+ * keys.
*
* Results:
* None.
@@ -1154,6 +1157,7 @@ ReleaseKeys(clientData)
{
Tcl_Obj **keys = (Tcl_Obj **)clientData;
int i;
+
for (i = KEY_CODE; i < KEY_LAST; i++) {
Tcl_DecrRefCount(keys[i]);
}
@@ -1164,11 +1168,11 @@ ReleaseKeys(clientData)
*
* TclProcessReturn --
*
- * Does the work of the [return] command based on the code,
- * level, and returnOpts arguments. Note that the code argument
- * must agree with the -code entry in returnOpts and the level
- * argument must agree with the -level entry in returnOpts, as
- * is the case for values returned from TclMergeReturnOptions.
+ * Does the work of the [return] command based on the code, level, and
+ * returnOpts arguments. Note that the code argument must agree with the
+ * -code entry in returnOpts and the level argument must agree with the
+ * -level entry in returnOpts, as is the case for values returned from
+ * TclMergeReturnOptions.
*
* Results:
* Returns the return code the [return] command should return.
@@ -1190,7 +1194,10 @@ TclProcessReturn(interp, code, level, returnOpts)
Tcl_Obj *valuePtr;
Tcl_Obj **keys = GetKeys();
- /* Store the merged return options */
+ /*
+ * Store the merged return options.
+ */
+
if (iPtr->returnOpts != returnOpts) {
if (iPtr->returnOpts) {
Tcl_DecrRefCount(iPtr->returnOpts);
@@ -1207,6 +1214,7 @@ TclProcessReturn(interp, code, level, returnOpts)
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr);
if (valuePtr != NULL) {
int infoLen;
+
(void) Tcl_GetStringFromObj(valuePtr, &infoLen);
if (infoLen) {
iPtr->errorInfo = valuePtr;
@@ -1242,9 +1250,9 @@ TclProcessReturn(interp, code, level, returnOpts)
* Parses, checks, and stores the options to the [return] command.
*
* Results:
- * Returns TCL_ERROR is any of the option values are invalid.
- * Otherwise, returns TCL_OK, and writes the returnOpts, code,
- * and level values to the pointers provided.
+ * Returns TCL_ERROR is any of the option values are invalid. Otherwise,
+ * returns TCL_OK, and writes the returnOpts, code, and level values to
+ * the pointers provided.
*
* Side effects:
* None.
@@ -1257,10 +1265,9 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
- Tcl_Obj **optionsPtrPtr; /* If not NULL, points to space for a
- * (Tcl_Obj *) where the pointer to the
- * merged return options dictionary should
- * be written */
+ Tcl_Obj **optionsPtrPtr; /* If not NULL, points to space for a (Tcl_Obj
+ * *) where the pointer to the merged return
+ * options dictionary should be written */
int *codePtr; /* If not NULL, points to space where the
* -code value should be written */
int *levelPtr; /* If not NULL, points to space where the
@@ -1285,13 +1292,16 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
Tcl_Obj *keyPtr;
Tcl_Obj *dict = objv[1];
- nestedOptions:
- if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict,
- &search, &keyPtr, &valuePtr, &done)) {
- /* Value is not a legal dictionary */
+ nestedOptions:
+ if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, &search,
+ &keyPtr, &valuePtr, &done)) {
+ /*
+ * Value is not a legal dictionary.
+ */
+
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad ",
- compare, " value: expected dictionary but got \"",
+ Tcl_AppendResult(interp, "bad ", compare,
+ " value: expected dictionary but got \"",
TclGetString(objv[1]), "\"", (char *) NULL);
goto error;
}
@@ -1313,9 +1323,12 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
}
}
- /* Check for bogus -code value */
+ /*
+ * Check for bogus -code value.
+ */
+
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
- if ((valuePtr != NULL)
+ if ((valuePtr != NULL)
&& (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) {
static CONST char *returnCodes[] = {
"ok", "error", "return", "break", "continue", NULL
@@ -1334,25 +1347,31 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]);
}
- /* Check for bogus -level value */
+ /*
+ * Check for bogus -level value.
+ */
+
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_LEVEL], &valuePtr);
if (valuePtr != NULL) {
- if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level))
+ if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level))
|| (level < 0)) {
- /* Value is not a legal level */
+ /*
+ * Value is not a legal level.
+ */
+
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad -level value: ",
- "expected non-negative integer but got \"",
- TclGetString(valuePtr), "\"", (char *) NULL);
+ "expected non-negative integer but got \"",
+ TclGetString(valuePtr), "\"", (char *) NULL);
goto error;
}
Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]);
}
- /*
- * Convert [return -code return -level X] to
- * [return -code ok -level X+1]
+ /*
+ * Convert [return -code return -level X] to [return -code ok -level X+1]
*/
+
if (code == TCL_RETURN) {
level++;
code = TCL_OK;
@@ -1364,15 +1383,19 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
if (levelPtr != NULL) {
*levelPtr = level;
}
+
if (optionsPtrPtr == NULL) {
- /* Not passing back the options (?!), so clean them up */
+ /*
+ * Not passing back the options (?!), so clean them up.
+ */
+
Tcl_DecrRefCount(returnOpts);
} else {
*optionsPtrPtr = returnOpts;
}
return TCL_OK;
-error:
+ error:
Tcl_DecrRefCount(returnOpts);
return TCL_ERROR;
}
@@ -1422,10 +1445,11 @@ Tcl_GetReturnOptions(interp, result)
if (result == TCL_ERROR) {
/*
- * When result was an error, fill in any missing values
- * for -errorinfo, -errorcode, and -errorline
+ * When result was an error, fill in any missing values for
+ * -errorinfo, -errorcode, and -errorline
*/
- Tcl_AddObjErrorInfo(interp, "", -1);
+
+ Tcl_AddObjErrorInfo(interp, "", -1);
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo);
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode);
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE],
@@ -1439,14 +1463,14 @@ Tcl_GetReturnOptions(interp, result)
*
* Tcl_SetReturnOptions --
*
- * Accepts an interp and a dictionary of return options, and sets
- * the return options of the interp to match the dictionary.
+ * Accepts an interp and a dictionary of return options, and sets the
+ * return options of the interp to match the dictionary.
*
* Results:
- * A standard status code. Usually TCL_OK, but TCL_ERROR if an
- * invalid option value was found in the dictionary. If a -level
- * value of 0 is in the dictionary, then the -code value in the
- * dictionary will be returned (TCL_OK default).
+ * A standard status code. Usually TCL_OK, but TCL_ERROR if an invalid
+ * option value was found in the dictionary. If a -level value of 0 is in
+ * the dictionary, then the -code value in the dictionary will be
+ * returned (TCL_OK default).
*
* Side effects:
* Sets the state of the interp.
@@ -1484,21 +1508,20 @@ Tcl_SetReturnOptions(interp, options)
*
* TclTransferResult --
*
- * Copy the result (and error information) from one interp to
- * another. Used when one interp has caused another interp to
- * evaluate a script and then wants to transfer the results back
- * to itself.
+ * Copy the result (and error information) from one interp to another.
+ * Used when one interp has caused another interp to evaluate a script
+ * and then wants to transfer the results back to itself.
*
- * This routine copies the string reps of the result and error
- * information. It does not simply increment the refcounts of the
- * result and error information objects themselves.
- * It is not legal to exchange objects between interps, because an
- * object may be kept alive by one interp, but have an internal rep
- * that is only valid while some other interp is alive.
+ * This routine copies the string reps of the result and error
+ * information. It does not simply increment the refcounts of the result
+ * and error information objects themselves. It is not legal to exchange
+ * objects between interps, because an object may be kept alive by one
+ * interp, but have an internal rep that is only valid while some other
+ * interp is alive.
*
* Results:
* The target interp's result is set to a copy of the source interp's
- * result. The source's errorInfo field may be transferred to the
+ * result. The source's errorInfo field may be transferred to the
* target's errorInfo field, and the source's errorCode field may be
* transferred to the target's errorCode field.
*
@@ -1507,19 +1530,19 @@ Tcl_SetReturnOptions(interp, options)
*
*-------------------------------------------------------------------------
*/
-
+
void
TclTransferResult(sourceInterp, result, targetInterp)
Tcl_Interp *sourceInterp; /* Interp whose result and error information
- * should be moved to the target interp.
- * After moving result, this interp's result
+ * should be moved to the target interp.
+ * After moving result, this interp's result
* is reset. */
- int result; /* TCL_OK if just the result should be copied,
- * TCL_ERROR if both the result and error
+ int result; /* TCL_OK if just the result should be copied,
+ * TCL_ERROR if both the result and error
* information should be copied. */
- Tcl_Interp *targetInterp; /* Interp where result and error information
- * should be stored. If source and target
- * are the same, nothing is done. */
+ Tcl_Interp *targetInterp; /* Interp where result and error information
+ * should be stored. If source and target are
+ * the same, nothing is done. */
{
Interp *iPtr = (Interp *) targetInterp;
@@ -1533,3 +1556,11 @@ TclTransferResult(sourceInterp, result, targetInterp)
Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
Tcl_ResetResult(sourceInterp);
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 0e8c1f1..b77620b 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -1,59 +1,57 @@
-/*
+/*
* tclStringObj.c --
*
- * This file contains procedures that implement string operations on Tcl
- * objects. Some string operations work with UTF strings and others
- * require Unicode format. Functions that require knowledge of the width
+ * This file contains functions that implement string operations on Tcl
+ * objects. Some string operations work with UTF strings and others
+ * require Unicode format. Functions that require knowledge of the width
* of each character, such as indexing, operate on Unicode data.
*
- * A Unicode string is an internationalized string. Conceptually, a
- * Unicode string is an array of 16-bit quantities organized as a sequence
- * of properly formed UTF-8 characters. There is a one-to-one map between
- * Unicode and UTF characters. Because Unicode characters have a fixed
- * width, operations such as indexing operate on Unicode data. The String
- * object is optimized for the case where each UTF char in a string is
- * only one byte. In this case, we store the value of numChars, but we
- * don't store the Unicode data (unless Tcl_GetUnicode is explicitly
- * called).
- *
- * The String object type stores one or both formats. The default
- * behavior is to store UTF. Once Unicode is calculated by a function, it
+ * A Unicode string is an internationalized string. Conceptually, a
+ * Unicode string is an array of 16-bit quantities organized as a
+ * sequence of properly formed UTF-8 characters. There is a one-to-one
+ * map between Unicode and UTF characters. Because Unicode characters
+ * have a fixed width, operations such as indexing operate on Unicode
+ * data. The String object is optimized for the case where each UTF char
+ * in a string is only one byte. In this case, we store the value of
+ * numChars, but we don't store the Unicode data (unless Tcl_GetUnicode
+ * is explicitly called).
+ *
+ * The String object type stores one or both formats. The default
+ * behavior is to store UTF. Once Unicode is calculated by a function, it
* is stored in the internal rep for future access (without an additional
* O(n) cost).
*
* To allow many appends to be done to an object without constantly
* reallocating the space for the string or Unicode representation, we
* allocate double the space for the string or Unicode and use the
- * internal representation to keep track of how much space is used
- * vs. allocated.
+ * internal representation to keep track of how much space is used vs.
+ * allocated.
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
* Copyright (c) 1999 by Scriptics Corporation.
*
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStringObj.c,v 1.37 2005/05/10 18:34:49 kennykb Exp $ */
+ * RCS: @(#) $Id: tclStringObj.c,v 1.38 2005/07/24 22:56:43 dkf Exp $ */
#include "tclInt.h"
/*
- * Prototypes for procedures defined later in this file:
+ * Prototypes for functions defined later in this file:
*/
static void AppendUnicodeToUnicodeRep _ANSI_ARGS_((
- Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
+ Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
int appendNumChars));
static void AppendUnicodeToUtfRep _ANSI_ARGS_((
- Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
+ Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
int numChars));
static void AppendUtfToUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr,
- CONST char *bytes, int numBytes));
+ CONST char *bytes, int numBytes));
static void AppendUtfToUtfRep _ANSI_ARGS_((Tcl_Obj *objPtr,
- CONST char *bytes, int numBytes));
-
+ CONST char *bytes, int numBytes));
static void FillUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr));
-
static void FreeStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static void DupStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
Tcl_Obj *copyPtr));
@@ -63,54 +61,58 @@ static void UpdateStringOfString _ANSI_ARGS_((Tcl_Obj *objPtr));
/*
* The structure below defines the string Tcl object type by means of
- * procedures that can be invoked by generic object code.
+ * functions that can be invoked by generic object code.
*/
Tcl_ObjType tclStringType = {
- "string", /* name */
- FreeStringInternalRep, /* freeIntRepPro */
- DupStringInternalRep, /* dupIntRepProc */
- UpdateStringOfString, /* updateStringProc */
- SetStringFromAny /* setFromAnyProc */
+ "string", /* name */
+ FreeStringInternalRep, /* freeIntRepPro */
+ DupStringInternalRep, /* dupIntRepProc */
+ UpdateStringOfString, /* updateStringProc */
+ SetStringFromAny /* setFromAnyProc */
};
/*
- * The following structure is the internal rep for a String object.
- * It keeps track of how much memory has been used and how much has been
- * allocated for the Unicode and UTF string to enable growing and
- * shrinking of the UTF and Unicode reps of the String object with fewer
- * mallocs. To optimize string length and indexing operations, this
- * structure also stores the number of characters (same of UTF and Unicode!)
- * once that value has been computed.
+ * The following structure is the internal rep for a String object. It keeps
+ * track of how much memory has been used and how much has been allocated for
+ * the Unicode and UTF string to enable growing and shrinking of the UTF and
+ * Unicode reps of the String object with fewer mallocs. To optimize string
+ * length and indexing operations, this structure also stores the number of
+ * characters (same of UTF and Unicode!) once that value has been computed.
+ *
+ * Under normal configurations, what Tcl calls "Unicode" is actually UTF-16
+ * restricted to the Basic Multilingual Plane (i.e. U+00000 to U+0FFFF). This
+ * can be officially modified by altering the definition of Tcl_UniChar in
+ * tcl.h, but do not do that unless you are sure what you're doing!
*/
typedef struct String {
- int numChars; /* The number of chars in the string.
- * -1 means this value has not been
- * calculated. >= 0 means that there is a
- * valid Unicode rep, or that the number
- * of UTF bytes == the number of chars. */
- size_t allocated; /* The amount of space actually allocated
- * for the UTF string (minus 1 byte for
- * the termination char). */
- size_t uallocated; /* The amount of space actually allocated
- * for the Unicode string (minus 2 bytes for
- * the termination char). */
- int hasUnicode; /* Boolean determining whether the string
- * has a Unicode representation. */
- Tcl_UniChar unicode[2]; /* The array of Unicode chars. The actual
- * size of this field depends on the
- * 'uallocated' field above. */
+ int numChars; /* The number of chars in the string. -1 means
+ * this value has not been calculated. >= 0
+ * means that there is a valid Unicode rep, or
+ * that the number of UTF bytes == the number
+ * of chars. */
+ size_t allocated; /* The amount of space actually allocated for
+ * the UTF string (minus 1 byte for the
+ * termination char). */
+ size_t uallocated; /* The amount of space actually allocated for
+ * the Unicode string (minus 2 bytes for the
+ * termination char). */
+ int hasUnicode; /* Boolean determining whether the string has
+ * a Unicode representation. */
+ Tcl_UniChar unicode[2]; /* The array of Unicode chars. The actual size
+ * of this field depends on the 'uallocated'
+ * field above. */
} String;
#define STRING_UALLOC(numChars) \
- (numChars * sizeof(Tcl_UniChar))
+ (numChars * sizeof(Tcl_UniChar))
#define STRING_SIZE(ualloc) \
- ((unsigned) (sizeof(String) - sizeof(Tcl_UniChar) + ualloc))
+ ((unsigned) (sizeof(String) - sizeof(Tcl_UniChar) + ualloc))
#define GET_STRING(objPtr) \
- ((String *) (objPtr)->internalRep.otherValuePtr)
+ ((String *) (objPtr)->internalRep.otherValuePtr)
#define SET_STRING(objPtr, stringPtr) \
- (objPtr)->internalRep.otherValuePtr = (VOID *) (stringPtr)
+ ((objPtr)->internalRep.otherValuePtr = (VOID *) (stringPtr))
/*
* TCL STRING GROWTH ALGORITHM
@@ -121,87 +123,82 @@ typedef struct String {
* Attempt to allocate 2 * (originalLength + appendLength)
* On failure:
* attempt to allocate originalLength + 2*appendLength +
- * TCL_GROWTH_MIN_ALLOC
+ * TCL_GROWTH_MIN_ALLOC
*
* This algorithm allows very good performance, as it rapidly increases the
* memory allocated for a given string, which minimizes the number of
- * reallocations that must be performed. However, using only the doubling
- * algorithm can lead to a significant waste of memory. In particular, it
- * may fail even when there is sufficient memory available to complete the
- * append request (but there is not 2 * totalLength memory available). So when
- * the doubling fails (because there is not enough memory available), the
+ * reallocations that must be performed. However, using only the doubling
+ * algorithm can lead to a significant waste of memory. In particular, it may
+ * fail even when there is sufficient memory available to complete the append
+ * request (but there is not 2*totalLength memory available). So when the
+ * doubling fails (because there is not enough memory available), the
* algorithm requests a smaller amount of memory, which is still enough to
- * cover the request, but which hopefully will be less than the total available
- * memory.
- *
- * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling
- * of very small appends. Without this extra slush factor, a sequence
- * of several small appends would cause several memory allocations.
- * As long as TCL_GROWTH_MIN_ALLOC is a reasonable size, we can
- * avoid that behavior.
+ * cover the request, but which hopefully will be less than the total
+ * available memory.
+ *
+ * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling of very
+ * small appends. Without this extra slush factor, a sequence of several small
+ * appends would cause several memory allocations. As long as
+ * TCL_GROWTH_MIN_ALLOC is a reasonable size, we can avoid that behavior.
*
* The growth algorithm can be tuned by adjusting the following parameters:
*
* TCL_GROWTH_MIN_ALLOC Additional space, in bytes, to allocate when
- * the double allocation has failed.
- * Default is 1024 (1 kilobyte).
+ * the double allocation has failed. Default is
+ * 1024 (1 kilobyte).
*/
+
#ifndef TCL_GROWTH_MIN_ALLOC
#define TCL_GROWTH_MIN_ALLOC 1024
#endif
-
/*
*----------------------------------------------------------------------
*
* Tcl_NewStringObj --
*
- * This procedure is normally called when not debugging: i.e., when
+ * This function is normally called when not debugging: i.e., when
* TCL_MEM_DEBUG is not defined. It creates a new string object and
* initializes it from the byte pointer and length arguments.
*
- * When TCL_MEM_DEBUG is defined, this procedure just returns the
- * result of calling the debugging version Tcl_DbNewStringObj.
+ * When TCL_MEM_DEBUG is defined, this function just returns the result
+ * of calling the debugging version Tcl_DbNewStringObj.
*
* Results:
* A newly created string object is returned that has ref count zero.
*
* Side effects:
- * The new object's internal string representation will be set to a
- * copy of the length bytes starting at "bytes". If "length" is
- * negative, use bytes up to the first NULL byte; i.e., assume "bytes"
- * points to a C-style NULL-terminated string. The object's type is set
- * to NULL. An extra NULL is added to the end of the new object's byte
- * array.
+ * The new object's internal string representation will be set to a copy
+ * of the length bytes starting at "bytes". If "length" is negative, use
+ * bytes up to the first NULL byte; i.e., assume "bytes" points to a
+ * C-style NULL-terminated string. The object's type is set to NULL. An
+ * extra NULL is added to the end of the new object's byte array.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewStringObj
-
Tcl_Obj *
Tcl_NewStringObj(bytes, length)
CONST char *bytes; /* Points to the first of the length bytes
* used to initialize the new object. */
int length; /* The number of bytes to copy from "bytes"
- * when initializing the new object. If
- * negative, use bytes up to the first
- * NULL byte. */
+ * when initializing the new object. If
+ * negative, use bytes up to the first NULL
+ * byte. */
{
return Tcl_DbNewStringObj(bytes, length, "unknown", 0);
}
-
#else /* if not TCL_MEM_DEBUG */
-
Tcl_Obj *
Tcl_NewStringObj(bytes, length)
CONST char *bytes; /* Points to the first of the length bytes
* used to initialize the new object. */
int length; /* The number of bytes to copy from "bytes"
- * when initializing the new object. If
- * negative, use bytes up to the first
- * NULL byte. */
+ * when initializing the new object. If
+ * negative, use bytes up to the first NULL
+ * byte. */
{
register Tcl_Obj *objPtr;
@@ -218,45 +215,43 @@ Tcl_NewStringObj(bytes, length)
*
* Tcl_DbNewStringObj --
*
- * This procedure is normally called when debugging: i.e., when
+ * This function is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It creates new string objects. It is the
- * same as the Tcl_NewStringObj procedure above except that it calls
+ * same as the Tcl_NewStringObj 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
+ * 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 procedure just returns the
+ * When TCL_MEM_DEBUG is not defined, this function just returns the
* result of calling Tcl_NewStringObj.
*
* Results:
* A newly created string object is returned that has ref count zero.
*
* Side effects:
- * The new object's internal string representation will be set to a
- * copy of the length bytes starting at "bytes". If "length" is
- * negative, use bytes up to the first NULL byte; i.e., assume "bytes"
- * points to a C-style NULL-terminated string. The object's type is set
- * to NULL. An extra NULL is added to the end of the new object's byte
- * array.
+ * The new object's internal string representation will be set to a copy
+ * of the length bytes starting at "bytes". If "length" is negative, use
+ * bytes up to the first NULL byte; i.e., assume "bytes" points to a
+ * C-style NULL-terminated string. The object's type is set to NULL. An
+ * extra NULL is added to the end of the new object's byte array.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
-
Tcl_Obj *
Tcl_DbNewStringObj(bytes, length, file, line)
CONST char *bytes; /* Points to the first of the length bytes
* used to initialize the new object. */
int length; /* The number of bytes to copy from "bytes"
- * when initializing the new object. If
- * negative, use bytes up to the first
- * NULL byte. */
+ * when initializing the new object. If
+ * negative, use bytes up to the first NULL
+ * byte. */
CONST char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+ * function; used for debugging. */
+ int line; /* Line number in the source file; used for
+ * debugging. */
{
register Tcl_Obj *objPtr;
@@ -267,21 +262,19 @@ Tcl_DbNewStringObj(bytes, length, file, line)
TclInitStringRep(objPtr, bytes, length);
return objPtr;
}
-
#else /* if not TCL_MEM_DEBUG */
-
Tcl_Obj *
Tcl_DbNewStringObj(bytes, length, file, line)
CONST char *bytes; /* Points to the first of the length bytes
* used to initialize the new object. */
register int length; /* The number of bytes to copy from "bytes"
- * when initializing the new object. If
- * negative, use bytes up to the first
- * NULL byte. */
+ * when initializing the new object. If
+ * negative, use bytes up to the first NULL
+ * byte. */
CONST char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+ * function; used for debugging. */
+ int line; /* Line number in the source file; used for
+ * debugging. */
{
return Tcl_NewStringObj(bytes, length);
}
@@ -292,14 +285,13 @@ Tcl_DbNewStringObj(bytes, length, file, line)
*
* Tcl_NewUnicodeObj --
*
- * This procedure is creates a new String object and initializes
- * it from the given Unicode String. If the Utf String is the same size
- * as the Unicode string, don't duplicate the data.
+ * This function is creates a new String object and initializes it from
+ * the given Unicode String. If the Utf String is the same size as the
+ * Unicode string, don't duplicate the data.
*
* Results:
- * The newly created object is returned. This object will have no
- * initial string representation. The returned object has a ref count
- * of 0.
+ * The newly created object is returned. This object will have no initial
+ * string representation. The returned object has a ref count of 0.
*
* Side effects:
* Memory allocated for new object and copy of Unicode argument.
@@ -309,8 +301,8 @@ Tcl_DbNewStringObj(bytes, length, file, line)
Tcl_Obj *
Tcl_NewUnicodeObj(unicode, numChars)
- CONST Tcl_UniChar *unicode; /* The unicode string used to initialize
- * the new object. */
+ CONST Tcl_UniChar *unicode; /* The unicode string used to initialize the
+ * new object. */
int numChars; /* Number of characters in the unicode
* string. */
{
@@ -321,7 +313,9 @@ Tcl_NewUnicodeObj(unicode, numChars)
if (numChars < 0) {
numChars = 0;
if (unicode) {
- while (unicode[numChars] != 0) { numChars++; }
+ while (unicode[numChars] != 0) {
+ numChars++;
+ }
}
}
uallocated = STRING_UALLOC(numChars);
@@ -356,60 +350,61 @@ Tcl_NewUnicodeObj(unicode, numChars)
* Pointer to unicode string representing the unicode object.
*
* Side effects:
- * Frees old internal rep. Allocates memory for new "String"
- * internal rep.
+ * Frees old internal rep. Allocates memory for new "String" internal
+ * rep.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetCharLength(objPtr)
- Tcl_Obj *objPtr; /* The String object to get the num chars of. */
+ Tcl_Obj *objPtr; /* The String object to get the num chars
+ * of. */
{
String *stringPtr;
-
+
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
/*
- * If numChars is unknown, then calculate the number of characaters
- * while populating the Unicode string.
+ * If numChars is unknown, then calculate the number of characaters while
+ * populating the Unicode string.
*/
-
+
if (stringPtr->numChars == -1) {
register int i = objPtr->length;
register unsigned char *str = (unsigned char *) objPtr->bytes;
/*
* This is a speed sensitive function, so run specially over the
- * string to count continuous ascii characters before resorting
- * to the Tcl_NumUtfChars call. This is a long form of:
- stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length);
- */
+ * string to count continuous ascii characters before resorting to the
+ * Tcl_NumUtfChars call. This is a long form of:
+ stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes,objPtr->length);
+ */
- while (i && (*str < 0xC0)) { i--; str++; }
+ while (i && (*str < 0xC0)) {
+ i--;
+ str++;
+ }
stringPtr->numChars = objPtr->length - i;
if (i) {
stringPtr->numChars += Tcl_NumUtfChars(objPtr->bytes
+ (objPtr->length - i), i);
}
- if (stringPtr->numChars == objPtr->length) {
-
+ if (stringPtr->numChars == objPtr->length) {
/*
- * Since we've just calculated the number of chars, and all
- * UTF chars are 1-byte long, we don't need to store the
- * unicode string.
+ * Since we've just calculated the number of chars, and all UTF
+ * chars are 1-byte long, we don't need to store the unicode
+ * string.
*/
stringPtr->hasUnicode = 0;
-
} else {
-
/*
- * Since we've just calucalated the number of chars, and not
- * all UTF chars are 1-byte long, go ahead and populate the
- * unicode string.
+ * Since we've just calucalated the number of chars, and not all
+ * UTF chars are 1-byte long, go ahead and populate the unicode
+ * string.
*/
FillUnicodeRep(objPtr);
@@ -418,7 +413,7 @@ Tcl_GetCharLength(objPtr)
* We need to fetch the pointer again because we have just
* reallocated the structure to make room for the Unicode data.
*/
-
+
stringPtr = GET_STRING(objPtr);
}
}
@@ -430,8 +425,8 @@ Tcl_GetCharLength(objPtr)
*
* Tcl_GetUniChar --
*
- * Get the index'th Unicode character from the String object. The
- * index is assumed to be in the appropriate range.
+ * Get the index'th Unicode character from the String object. The index
+ * is assumed to be in the appropriate range.
*
* Results:
* Returns the index'th Unicode character in the Object.
@@ -444,21 +439,20 @@ Tcl_GetCharLength(objPtr)
Tcl_UniChar
Tcl_GetUniChar(objPtr, index)
- Tcl_Obj *objPtr; /* The object to get the Unicode charater from. */
- int index; /* Get the index'th Unicode character. */
+ Tcl_Obj *objPtr; /* The object to get the Unicode charater
+ * from. */
+ int index; /* Get the index'th Unicode character. */
{
Tcl_UniChar unichar;
String *stringPtr;
-
+
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if (stringPtr->numChars == -1) {
-
/*
- * We haven't yet calculated the length, so we don't have the
- * Unicode str. We need to know the number of chars before we
- * can do indexing.
+ * We haven't yet calculated the length, so we don't have the Unicode
+ * str. We need to know the number of chars before we can do indexing.
*/
Tcl_GetCharLength(objPtr);
@@ -467,15 +461,14 @@ Tcl_GetUniChar(objPtr, index)
* We need to fetch the pointer again because we may have just
* reallocated the structure.
*/
-
+
stringPtr = GET_STRING(objPtr);
}
if (stringPtr->hasUnicode == 0) {
-
/*
- * All of the characters in the Utf string are 1 byte chars,
- * so we don't store the unicode char. We get the Utf string
- * and convert the index'th byte to a Unicode character.
+ * All of the characters in the Utf string are 1 byte chars, so we
+ * don't store the unicode char. We get the Utf string and convert the
+ * index'th byte to a Unicode character.
*/
unichar = (Tcl_UniChar) objPtr->bytes[index];
@@ -490,10 +483,10 @@ Tcl_GetUniChar(objPtr, index)
*
* Tcl_GetUnicode --
*
- * Get the Unicode form of the String object. If
- * the object is not already a String object, it will be converted
- * to one. If the String object does not have a Unicode rep, then
- * one is create from the UTF string format.
+ * Get the Unicode form of the String object. If the object is not
+ * already a String object, it will be converted to one. If the String
+ * object does not have a Unicode rep, then one is create from the UTF
+ * string format.
*
* Results:
* Returns a pointer to the object's internal Unicode string.
@@ -506,30 +499,30 @@ Tcl_GetUniChar(objPtr, index)
Tcl_UniChar *
Tcl_GetUnicode(objPtr)
- Tcl_Obj *objPtr; /* The object to find the unicode string for. */
+ Tcl_Obj *objPtr; /* The object to find the unicode string
+ * for. */
{
String *stringPtr;
-
+
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
-
- if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {
+ if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {
/*
- * We haven't yet calculated the length, or all of the characters
- * in the Utf string are 1 byte chars (so we didn't store the
- * unicode str). Since this function must return a unicode string,
- * and one has not yet been stored, force the Unicode to be
- * calculated and stored now.
+ * We haven't yet calculated the length, or all of the characters in
+ * the Utf string are 1 byte chars (so we didn't store the unicode
+ * str). Since this function must return a unicode string, and one has
+ * not yet been stored, force the Unicode to be calculated and stored
+ * now.
*/
FillUnicodeRep(objPtr);
/*
- * We need to fetch the pointer again because we have just
- * reallocated the structure to make room for the Unicode data.
+ * We need to fetch the pointer again because we have just reallocated
+ * the structure to make room for the Unicode data.
*/
-
+
stringPtr = GET_STRING(objPtr);
}
return stringPtr->unicode;
@@ -540,10 +533,10 @@ Tcl_GetUnicode(objPtr)
*
* Tcl_GetUnicodeFromObj --
*
- * Get the Unicode form of the String object with length. If
- * the object is not already a String object, it will be converted
- * to one. If the String object does not have a Unicode rep, then
- * one is create from the UTF string format.
+ * Get the Unicode form of the String object with length. If the object
+ * is not already a String object, it will be converted to one. If the
+ * String object does not have a Unicode rep, then one is create from the
+ * UTF string format.
*
* Results:
* Returns a pointer to the object's internal Unicode string.
@@ -556,33 +549,33 @@ Tcl_GetUnicode(objPtr)
Tcl_UniChar *
Tcl_GetUnicodeFromObj(objPtr, lengthPtr)
- Tcl_Obj *objPtr; /* The object to find the unicode string for. */
- int *lengthPtr; /* If non-NULL, the location where the
- * string rep's unichar length should be
- * stored. If NULL, no length is stored. */
+ Tcl_Obj *objPtr; /* The object to find the unicode string
+ * for. */
+ int *lengthPtr; /* If non-NULL, the location where the string
+ * rep's unichar length should be stored. If
+ * NULL, no length is stored. */
{
String *stringPtr;
-
+
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
-
- if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {
+ if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {
/*
- * We haven't yet calculated the length, or all of the characters
- * in the Utf string are 1 byte chars (so we didn't store the
- * unicode str). Since this function must return a unicode string,
- * and one has not yet been stored, force the Unicode to be
- * calculated and stored now.
+ * We haven't yet calculated the length, or all of the characters in
+ * the Utf string are 1 byte chars (so we didn't store the unicode
+ * str). Since this function must return a unicode string, and one has
+ * not yet been stored, force the Unicode to be calculated and stored
+ * now.
*/
FillUnicodeRep(objPtr);
/*
- * We need to fetch the pointer again because we have just
- * reallocated the structure to make room for the Unicode data.
+ * We need to fetch the pointer again because we have just reallocated
+ * the structure to make room for the Unicode data.
*/
-
+
stringPtr = GET_STRING(objPtr);
}
@@ -597,10 +590,10 @@ Tcl_GetUnicodeFromObj(objPtr, lengthPtr)
*
* Tcl_GetRange --
*
- * Create a Tcl Object that contains the chars between first and last
- * of the object indicated by "objPtr". If the object is not already
- * a String object, convert it to one. The first and last indices
- * are assumed to be in the appropriate range.
+ * Create a Tcl Object that contains the chars between first and last of
+ * the object indicated by "objPtr". If the object is not already a
+ * String object, convert it to one. The first and last indices are
+ * assumed to be in the appropriate range.
*
* Results:
* Returns a new Tcl Object of the String type.
@@ -619,16 +612,14 @@ Tcl_GetRange(objPtr, first, last)
{
Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */
String *stringPtr;
-
+
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if (stringPtr->numChars == -1) {
-
/*
- * We haven't yet calculated the length, so we don't have the
- * Unicode str. We need to know the number of chars before we
- * can do indexing.
+ * We haven't yet calculated the length, so we don't have the Unicode
+ * str. We need to know the number of chars before we can do indexing.
*/
Tcl_GetCharLength(objPtr);
@@ -637,7 +628,7 @@ Tcl_GetRange(objPtr, first, last)
* We need to fetch the pointer again because we may have just
* reallocated the structure.
*/
-
+
stringPtr = GET_STRING(objPtr);
}
@@ -645,18 +636,18 @@ Tcl_GetRange(objPtr, first, last)
char *str = Tcl_GetString(objPtr);
/*
- * All of the characters in the Utf string are 1 byte chars,
- * so we don't store the unicode char. Create a new string
- * object containing the specified range of chars.
+ * All of the characters in the Utf string are 1 byte chars, so we
+ * don't store the unicode char. Create a new string object containing
+ * the specified range of chars.
*/
-
+
newObjPtr = Tcl_NewStringObj(&str[first], last-first+1);
/*
- * Since we know the new string only has 1-byte chars, we
- * can set it's numChars field.
+ * Since we know the new string only has 1-byte chars, we can set it's
+ * numChars field.
*/
-
+
SetStringFromAny(NULL, newObjPtr);
stringPtr = GET_STRING(newObjPtr);
stringPtr->numChars = last-first+1;
@@ -673,16 +664,16 @@ Tcl_GetRange(objPtr, first, last)
* Tcl_SetStringObj --
*
* Modify an object to hold a string that is a copy of the bytes
- * indicated by the byte pointer and length arguments.
+ * indicated by the byte pointer and length arguments.
*
* Results:
* None.
*
* Side effects:
- * The object's string representation will be set to a copy of
- * the "length" bytes starting at "bytes". If "length" is negative, use
- * bytes up to the first NULL byte; i.e., assume "bytes" points to a
- * C-style NULL-terminated string. The object's old string and internal
+ * The object's string representation will be set to a copy of the
+ * "length" bytes starting at "bytes". If "length" is negative, use bytes
+ * up to the first NULL byte; i.e., assume "bytes" points to a C-style
+ * NULL-terminated string. The object's old string and internal
* representations are freed and the object's type is set NULL.
*
*----------------------------------------------------------------------
@@ -694,13 +685,12 @@ Tcl_SetStringObj(objPtr, bytes, length)
CONST char *bytes; /* Points to the first of the length bytes
* used to initialize the object. */
register int length; /* The number of bytes to copy from "bytes"
- * when initializing the object. If
- * negative, use bytes up to the first
- * NULL byte.*/
+ * when initializing the object. If negative,
+ * use bytes up to the first NULL byte.*/
{
/*
- * Free any old string rep, then set the string rep to a copy of
- * the length bytes starting at "bytes".
+ * Free any old string rep, then set the string rep to a copy of the
+ * length bytes starting at "bytes".
*/
if (Tcl_IsShared(objPtr)) {
@@ -726,20 +716,19 @@ Tcl_SetStringObj(objPtr, bytes, length)
*
* Tcl_SetObjLength --
*
- * This procedure changes the length of the string representation
- * of an object.
+ * This function changes the length of the string representation of an
+ * object.
*
* Results:
* None.
*
* Side effects:
- * If the size of objPtr's string representation is greater than
- * length, then it is reduced to length and a new terminating null
- * byte is stored in the strength. If the length of the string
- * representation is greater than length, the storage space is
- * reallocated to the given length; a null byte is stored at the
- * end, but other bytes past the end of the original string
- * representation are undefined. The object's internal
+ * If the size of objPtr's string representation is greater than length,
+ * then it is reduced to length and a new terminating null byte is stored
+ * in the strength. If the length of the string representation is greater
+ * than length, the storage space is reallocated to the given length; a
+ * null byte is stored at the end, but other bytes past the end of the
+ * original string representation are undefined. The object's internal
* representation is changed to "expendable string".
*
*----------------------------------------------------------------------
@@ -747,8 +736,8 @@ Tcl_SetStringObj(objPtr, bytes, length)
void
Tcl_SetObjLength(objPtr, length)
- register Tcl_Obj *objPtr; /* Pointer to object. This object must
- * not currently be shared. */
+ register Tcl_Obj *objPtr; /* Pointer to object. This object must not
+ * currently be shared. */
register int length; /* Number of bytes desired for string
* representation of object, not including
* terminating null byte. */
@@ -759,19 +748,22 @@ Tcl_SetObjLength(objPtr, length)
Tcl_Panic("Tcl_SetObjLength called with shared object");
}
SetStringFromAny(NULL, objPtr);
-
+
stringPtr = GET_STRING(objPtr);
-
- /* Check that we're not extending a pure unicode string */
-
- if (length > (int) stringPtr->allocated &&
+
+ /*
+ * Check that we're not extending a pure unicode string.
+ */
+
+ if (length > (int) stringPtr->allocated &&
(objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) {
char *new;
/*
- * Not enough space in current string. Reallocate the string
- * space and free the old string.
+ * Not enough space in current string. Reallocate the string space and
+ * free the old string.
*/
+
if (objPtr->bytes != tclEmptyStringRep && objPtr->bytes != NULL) {
new = (char *) ckrealloc((char *)objPtr->bytes,
(unsigned)(length+1));
@@ -785,34 +777,53 @@ Tcl_SetObjLength(objPtr, length)
}
objPtr->bytes = new;
stringPtr->allocated = length;
- /* Invalidate the unicode data. */
+
+ /*
+ * Invalidate the unicode data.
+ */
+
stringPtr->hasUnicode = 0;
}
-
+
if (objPtr->bytes != NULL) {
- objPtr->length = length;
- if (objPtr->bytes != tclEmptyStringRep) {
- /* Ensure the string is NULL-terminated */
- objPtr->bytes[length] = 0;
- }
- /* Invalidate the unicode data. */
- stringPtr->numChars = -1;
- stringPtr->hasUnicode = 0;
+ objPtr->length = length;
+ if (objPtr->bytes != tclEmptyStringRep) {
+ /*
+ * Ensure the string is NULL-terminated.
+ */
+
+ objPtr->bytes[length] = 0;
+ }
+
+ /*
+ * Invalidate the unicode data.
+ */
+
+ stringPtr->numChars = -1;
+ stringPtr->hasUnicode = 0;
} else {
- /* Changing length of pure unicode string */
- size_t uallocated = STRING_UALLOC(length);
- if (uallocated > stringPtr->uallocated) {
- stringPtr = (String *) ckrealloc((char*) stringPtr,
- STRING_SIZE(uallocated));
- SET_STRING(objPtr, stringPtr);
- stringPtr->uallocated = uallocated;
- }
- stringPtr->numChars = length;
- stringPtr->hasUnicode = (length > 0);
- /* Ensure the string is NULL-terminated */
- stringPtr->unicode[length] = 0;
- stringPtr->allocated = 0;
- objPtr->length = 0;
+ /*
+ * Changing length of pure unicode string.
+ */
+
+ size_t uallocated = STRING_UALLOC(length);
+
+ if (uallocated > stringPtr->uallocated) {
+ stringPtr = (String *) ckrealloc((char*) stringPtr,
+ STRING_SIZE(uallocated));
+ SET_STRING(objPtr, stringPtr);
+ stringPtr->uallocated = uallocated;
+ }
+ stringPtr->numChars = length;
+ stringPtr->hasUnicode = (length > 0);
+
+ /*
+ * Ensure the string is NULL-terminated.
+ */
+
+ stringPtr->unicode[length] = 0;
+ stringPtr->allocated = 0;
+ objPtr->length = 0;
}
}
@@ -821,20 +832,19 @@ Tcl_SetObjLength(objPtr, length)
*
* Tcl_AttemptSetObjLength --
*
- * This procedure changes the length of the string representation
- * of an object. It uses the attempt* (non-panic'ing) memory allocators.
+ * This function changes the length of the string representation of an
+ * object. It uses the attempt* (non-panic'ing) memory allocators.
*
* Results:
* 1 if the requested memory was allocated, 0 otherwise.
*
* Side effects:
- * If the size of objPtr's string representation is greater than
- * length, then it is reduced to length and a new terminating null
- * byte is stored in the strength. If the length of the string
- * representation is greater than length, the storage space is
- * reallocated to the given length; a null byte is stored at the
- * end, but other bytes past the end of the original string
- * representation are undefined. The object's internal
+ * If the size of objPtr's string representation is greater than length,
+ * then it is reduced to length and a new terminating null byte is stored
+ * in the strength. If the length of the string representation is greater
+ * than length, the storage space is reallocated to the given length; a
+ * null byte is stored at the end, but other bytes past the end of the
+ * original string representation are undefined. The object's internal
* representation is changed to "expendable string".
*
*----------------------------------------------------------------------
@@ -842,8 +852,8 @@ Tcl_SetObjLength(objPtr, length)
int
Tcl_AttemptSetObjLength(objPtr, length)
- register Tcl_Obj *objPtr; /* Pointer to object. This object must
- * not currently be shared. */
+ register Tcl_Obj *objPtr; /* Pointer to object. This object must not
+ * currently be shared. */
register int length; /* Number of bytes desired for string
* representation of object, not including
* terminating null byte. */
@@ -854,19 +864,22 @@ Tcl_AttemptSetObjLength(objPtr, length)
Tcl_Panic("Tcl_AttemptSetObjLength called with shared object");
}
SetStringFromAny(NULL, objPtr);
-
+
stringPtr = GET_STRING(objPtr);
- /* Check that we're not extending a pure unicode string */
+ /*
+ * Check that we're not extending a pure unicode string.
+ */
- if (length > (int) stringPtr->allocated &&
+ if (length > (int) stringPtr->allocated &&
(objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) {
char *new;
/*
- * Not enough space in current string. Reallocate the string
- * space and free the old string.
+ * Not enough space in current string. Reallocate the string space and
+ * free the old string.
*/
+
if (objPtr->bytes != tclEmptyStringRep && objPtr->bytes != NULL) {
new = (char *) attemptckrealloc((char *)objPtr->bytes,
(unsigned)(length+1));
@@ -879,41 +892,60 @@ Tcl_AttemptSetObjLength(objPtr, length)
return 0;
}
if (objPtr->bytes != NULL && objPtr->length != 0) {
- memcpy((VOID *) new, (VOID *) objPtr->bytes,
- (size_t) objPtr->length);
- Tcl_InvalidateStringRep(objPtr);
+ memcpy((VOID *) new, (VOID *) objPtr->bytes,
+ (size_t) objPtr->length);
+ Tcl_InvalidateStringRep(objPtr);
}
}
objPtr->bytes = new;
stringPtr->allocated = length;
- /* Invalidate the unicode data. */
+
+ /*
+ * Invalidate the unicode data.
+ */
+
stringPtr->hasUnicode = 0;
}
-
+
if (objPtr->bytes != NULL) {
objPtr->length = length;
if (objPtr->bytes != tclEmptyStringRep) {
- /* Ensure the string is NULL-terminated */
+ /*
+ * Ensure the string is NULL-terminated.
+ */
+
objPtr->bytes[length] = 0;
}
- /* Invalidate the unicode data. */
+
+ /*
+ * Invalidate the unicode data.
+ */
+
stringPtr->numChars = -1;
stringPtr->hasUnicode = 0;
} else {
- /* Changing length of pure unicode string */
+ /*
+ * Changing length of pure unicode string.
+ */
+
size_t uallocated = STRING_UALLOC(length);
+
if (uallocated > stringPtr->uallocated) {
stringPtr = (String *) attemptckrealloc((char*) stringPtr,
STRING_SIZE(uallocated));
if (stringPtr == NULL) {
- return 0;
+ return 0;
}
SET_STRING(objPtr, stringPtr);
stringPtr->uallocated = uallocated;
}
stringPtr->numChars = length;
stringPtr->hasUnicode = (length > 0);
- /* Ensure the string is NULL-terminated */
+
+ /*
+ * Ensure the string is NULL-terminated.
+ */
+
stringPtr->unicode[length] = 0;
stringPtr->allocated = 0;
objPtr->length = 0;
@@ -940,8 +972,8 @@ Tcl_AttemptSetObjLength(objPtr, length)
void
Tcl_SetUnicodeObj(objPtr, unicode, numChars)
Tcl_Obj *objPtr; /* The object to set the string of. */
- CONST Tcl_UniChar *unicode; /* The unicode string used to initialize
- * the object. */
+ CONST Tcl_UniChar *unicode; /* The unicode string used to initialize the
+ * object. */
int numChars; /* Number of characters in the unicode
* string. */
{
@@ -951,7 +983,9 @@ Tcl_SetUnicodeObj(objPtr, unicode, numChars)
if (numChars < 0) {
numChars = 0;
if (unicode) {
- while (unicode[numChars] != 0) { numChars++; }
+ while (unicode[numChars] != 0) {
+ numChars++;
+ }
}
}
uallocated = STRING_UALLOC(numChars);
@@ -966,7 +1000,7 @@ Tcl_SetUnicodeObj(objPtr, unicode, numChars)
/*
* Allocate enough space for the String structure + Unicode string.
*/
-
+
stringPtr = (String *) ckalloc(STRING_SIZE(uallocated));
stringPtr->numChars = numChars;
stringPtr->uallocated = uallocated;
@@ -974,6 +1008,7 @@ Tcl_SetUnicodeObj(objPtr, unicode, numChars)
stringPtr->allocated = 0;
memcpy((VOID *) stringPtr->unicode, (VOID *) unicode, uallocated);
stringPtr->unicode[numChars] = 0;
+
SET_STRING(objPtr, stringPtr);
Tcl_InvalidateStringRep(objPtr);
return;
@@ -984,15 +1019,15 @@ Tcl_SetUnicodeObj(objPtr, unicode, numChars)
*
* TclAppendLimitedToObj --
*
- * This procedure appends a limited number of bytes from a sequence
- * of bytes to an object, marking any limitation with an ellipsis.
+ * This function appends a limited number of bytes from a sequence of
+ * bytes to an object, marking any limitation with an ellipsis.
*
* Results:
* None.
*
* Side effects:
- * The bytes at *bytes are appended to the string representation
- * of objPtr.
+ * The bytes at *bytes are appended to the string representation of
+ * objPtr.
*
*----------------------------------------------------------------------
*/
@@ -1003,13 +1038,13 @@ TclAppendLimitedToObj(objPtr, bytes, length, limit, ellipsis)
CONST char *bytes; /* Points to the bytes to append to the
* object. */
register int length; /* The number of bytes available to be
- * appended from "bytes". If < 0, then
- * all bytes up to a NULL byte are available. */
- register int limit; /* The maximum number of bytes to append
- * to the object. */
- CONST char *ellipsis; /* Ellipsis marker string, appended to
- * the object to indicate not all available
- * bytes at "bytes" were appended. */
+ * appended from "bytes". If < 0, then all
+ * bytes up to a NULL byte are available. */
+ register int limit; /* The maximum number of bytes to append to
+ * the object. */
+ CONST char *ellipsis; /* Ellipsis marker string, appended to the
+ * object to indicate not all available bytes
+ * at "bytes" were appended. */
{
String *stringPtr;
int toCopy = 0;
@@ -1037,9 +1072,9 @@ TclAppendLimitedToObj(objPtr, bytes, length, limit, ellipsis)
}
/*
- * If objPtr has a valid Unicode rep, then append the Unicode
- * conversion of "bytes" to the objPtr's Unicode rep, otherwise
- * append "bytes" to objPtr's string rep.
+ * If objPtr has a valid Unicode rep, then append the Unicode conversion
+ * of "bytes" to the objPtr's Unicode rep, otherwise append "bytes" to
+ * objPtr's string rep.
*/
stringPtr = GET_STRING(objPtr);
@@ -1059,7 +1094,6 @@ TclAppendLimitedToObj(objPtr, bytes, length, limit, ellipsis)
} else {
AppendUtfToUtfRep(objPtr, ellipsis, -1);
}
-
}
/*
@@ -1067,14 +1101,14 @@ TclAppendLimitedToObj(objPtr, bytes, length, limit, ellipsis)
*
* Tcl_AppendToObj --
*
- * This procedure appends a sequence of bytes to an object.
+ * This function appends a sequence of bytes to an object.
*
* Results:
* None.
*
* Side effects:
- * The bytes at *bytes are appended to the string representation
- * of objPtr.
+ * The bytes at *bytes are appended to the string representation of
+ * objPtr.
*
*----------------------------------------------------------------------
*/
@@ -1084,9 +1118,9 @@ Tcl_AppendToObj(objPtr, bytes, length)
register Tcl_Obj *objPtr; /* Points to the object to append to. */
CONST char *bytes; /* Points to the bytes to append to the
* object. */
- register int length; /* The number of bytes to append from
- * "bytes". If < 0, then append all bytes
- * up to NULL byte. */
+ register int length; /* The number of bytes to append from "bytes".
+ * If < 0, then append all bytes up to NULL
+ * byte. */
{
TclAppendLimitedToObj(objPtr, bytes, length, INT_MAX, NULL);
}
@@ -1096,8 +1130,8 @@ Tcl_AppendToObj(objPtr, bytes, length)
*
* Tcl_AppendUnicodeToObj --
*
- * This procedure appends a Unicode string to an object in the
- * most efficient manner possible. Length must be >= 0.
+ * This function appends a Unicode string to an object in the most
+ * efficient manner possible. Length must be >= 0.
*
* Results:
* None.
@@ -1112,7 +1146,7 @@ void
Tcl_AppendUnicodeToObj(objPtr, unicode, length)
register Tcl_Obj *objPtr; /* Points to the object to append to. */
CONST Tcl_UniChar *unicode; /* The unicode string to append to the
- * object. */
+ * object. */
int length; /* Number of chars in "unicode". */
{
String *stringPtr;
@@ -1129,9 +1163,9 @@ Tcl_AppendUnicodeToObj(objPtr, unicode, length)
stringPtr = GET_STRING(objPtr);
/*
- * If objPtr has a valid Unicode rep, then append the "unicode"
- * to the objPtr's Unicode rep, otherwise the UTF conversion of
- * "unicode" to objPtr's string rep.
+ * If objPtr has a valid Unicode rep, then append the "unicode" to the
+ * objPtr's Unicode rep, otherwise the UTF conversion of "unicode" to
+ * objPtr's string rep.
*/
if (stringPtr->hasUnicode != 0) {
@@ -1146,14 +1180,14 @@ Tcl_AppendUnicodeToObj(objPtr, unicode, length)
*
* Tcl_AppendObjToObj --
*
- * This procedure appends the string rep of one object to another.
+ * This function appends the string rep of one object to another.
* "objPtr" cannot be a shared object.
*
* Results:
* None.
*
* Side effects:
- * The string rep of appendObjPtr is appended to the string
+ * The string rep of appendObjPtr is appended to the string
* representation of objPtr.
*
*----------------------------------------------------------------------
@@ -1171,25 +1205,22 @@ Tcl_AppendObjToObj(objPtr, appendObjPtr)
SetStringFromAny(NULL, objPtr);
/*
- * If objPtr has a valid Unicode rep, then get a Unicode string
- * from appendObjPtr and append it.
+ * If objPtr has a valid Unicode rep, then get a Unicode string from
+ * appendObjPtr and append it.
*/
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode != 0) {
-
/*
* If appendObjPtr is not of the "String" type, don't convert it.
*/
if (appendObjPtr->typePtr == &tclStringType) {
stringPtr = GET_STRING(appendObjPtr);
- if ((stringPtr->numChars == -1)
- || (stringPtr->hasUnicode == 0)) {
-
+ if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {
/*
- * If appendObjPtr is a string obj with no valid Unicode
- * rep, then fill its unicode rep.
+ * If appendObjPtr is a string obj with no valid Unicode rep,
+ * then fill its unicode rep.
*/
FillUnicodeRep(appendObjPtr);
@@ -1205,9 +1236,9 @@ Tcl_AppendObjToObj(objPtr, appendObjPtr)
}
/*
- * Append to objPtr's UTF string rep. If we know the number of
- * characters in both objects before appending, then set the combined
- * number of characters in the final (appended-to) object.
+ * Append to objPtr's UTF string rep. If we know the number of characters
+ * in both objects before appending, then set the combined number of
+ * characters in the final (appended-to) object.
*/
bytes = Tcl_GetStringFromObj(appendObjPtr, &length);
@@ -1235,8 +1266,8 @@ Tcl_AppendObjToObj(objPtr, appendObjPtr)
*
* AppendUnicodeToUnicodeRep --
*
- * This procedure appends the contents of "unicode" to the Unicode
- * rep of "objPtr". objPtr must already have a valid Unicode rep.
+ * This function appends the contents of "unicode" to the Unicode rep of
+ * "objPtr". objPtr must already have a valid Unicode rep.
*
* Results:
* None.
@@ -1249,9 +1280,9 @@ Tcl_AppendObjToObj(objPtr, appendObjPtr)
static void
AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars)
- Tcl_Obj *objPtr; /* Points to the object to append to. */
- CONST Tcl_UniChar *unicode; /* String to append. */
- int appendNumChars; /* Number of chars of "unicode" to append. */
+ Tcl_Obj *objPtr; /* Points to the object to append to. */
+ CONST Tcl_UniChar *unicode; /* String to append. */
+ int appendNumChars; /* Number of chars of "unicode" to append. */
{
String *stringPtr, *tmpString;
size_t numChars;
@@ -1259,7 +1290,9 @@ AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars)
if (appendNumChars < 0) {
appendNumChars = 0;
if (unicode) {
- while (unicode[appendNumChars] != 0) { appendNumChars++; }
+ while (unicode[appendNumChars] != 0) {
+ appendNumChars++;
+ }
}
}
if (appendNumChars == 0) {
@@ -1270,23 +1303,23 @@ AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars)
stringPtr = GET_STRING(objPtr);
/*
- * If not enough space has been allocated for the unicode rep,
- * reallocate the internal rep object with additional space. First
- * try to double the required allocation; if that fails, try a more
- * modest increase. See the "TCL STRING GROWTH ALGORITHM" comment at
- * the top of this file for an explanation of this growth algorithm.
+ * If not enough space has been allocated for the unicode rep, reallocate
+ * the internal rep object with additional space. First try to double the
+ * required allocation; if that fails, try a more modest increase. See the
+ * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an
+ * explanation of this growth algorithm.
*/
numChars = stringPtr->numChars + appendNumChars;
if (STRING_UALLOC(numChars) >= stringPtr->uallocated) {
- stringPtr->uallocated = STRING_UALLOC(2 * numChars);
+ stringPtr->uallocated = STRING_UALLOC(2 * numChars);
tmpString = (String *) attemptckrealloc((char *)stringPtr,
STRING_SIZE(stringPtr->uallocated));
if (tmpString == NULL) {
stringPtr->uallocated =
- STRING_UALLOC(numChars + appendNumChars)
- + TCL_GROWTH_MIN_ALLOC;
+ STRING_UALLOC(numChars + appendNumChars)
+ + TCL_GROWTH_MIN_ALLOC;
tmpString = (String *) ckrealloc((char *)stringPtr,
STRING_SIZE(stringPtr->uallocated));
}
@@ -1312,8 +1345,8 @@ AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars)
*
* AppendUnicodeToUtfRep --
*
- * This procedure converts the contents of "unicode" to UTF and
- * appends the UTF to the string rep of "objPtr".
+ * This function converts the contents of "unicode" to UTF and appends
+ * the UTF to the string rep of "objPtr".
*
* Results:
* None.
@@ -1326,17 +1359,19 @@ AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars)
static void
AppendUnicodeToUtfRep(objPtr, unicode, numChars)
- Tcl_Obj *objPtr; /* Points to the object to append to. */
- CONST Tcl_UniChar *unicode; /* String to convert to UTF. */
- int numChars; /* Number of chars of "unicode" to convert. */
+ Tcl_Obj *objPtr; /* Points to the object to append to. */
+ CONST Tcl_UniChar *unicode; /* String to convert to UTF. */
+ int numChars; /* Number of chars of "unicode" to convert. */
{
Tcl_DString dsPtr;
CONST char *bytes;
-
+
if (numChars < 0) {
numChars = 0;
if (unicode) {
- while (unicode[numChars] != 0) { numChars++; }
+ while (unicode[numChars] != 0) {
+ numChars++;
+ }
}
}
if (numChars == 0) {
@@ -1354,9 +1389,9 @@ AppendUnicodeToUtfRep(objPtr, unicode, numChars)
*
* AppendUtfToUnicodeRep --
*
- * This procedure converts the contents of "bytes" to Unicode and
- * appends the Unicode to the Unicode rep of "objPtr". objPtr must
- * already have a valid Unicode rep.
+ * This function converts the contents of "bytes" to Unicode and appends
+ * the Unicode to the Unicode rep of "objPtr". objPtr must already have a
+ * valid Unicode rep.
*
* Results:
* None.
@@ -1369,9 +1404,9 @@ AppendUnicodeToUtfRep(objPtr, unicode, numChars)
static void
AppendUtfToUnicodeRep(objPtr, bytes, numBytes)
- Tcl_Obj *objPtr; /* Points to the object to append to. */
- CONST char *bytes; /* String to convert to Unicode. */
- int numBytes; /* Number of bytes of "bytes" to convert. */
+ Tcl_Obj *objPtr; /* Points to the object to append to. */
+ CONST char *bytes; /* String to convert to Unicode. */
+ int numBytes; /* Number of bytes of "bytes" to convert. */
{
Tcl_DString dsPtr;
int numChars;
@@ -1383,7 +1418,7 @@ AppendUtfToUnicodeRep(objPtr, bytes, numBytes)
if (numBytes == 0) {
return;
}
-
+
Tcl_DStringInit(&dsPtr);
numChars = Tcl_NumUtfChars(bytes, numBytes);
unicode = (Tcl_UniChar *)Tcl_UtfToUniCharDString(bytes, numBytes, &dsPtr);
@@ -1396,8 +1431,8 @@ AppendUtfToUnicodeRep(objPtr, bytes, numBytes)
*
* AppendUtfToUtfRep --
*
- * This procedure appends "numBytes" bytes of "bytes" to the UTF string
- * rep of "objPtr". objPtr must already have a valid String rep.
+ * This function appends "numBytes" bytes of "bytes" to the UTF string
+ * rep of "objPtr". objPtr must already have a valid String rep.
*
* Results:
* None.
@@ -1410,9 +1445,9 @@ AppendUtfToUnicodeRep(objPtr, bytes, numBytes)
static void
AppendUtfToUtfRep(objPtr, bytes, numBytes)
- Tcl_Obj *objPtr; /* Points to the object to append to. */
- CONST char *bytes; /* String to append. */
- int numBytes; /* Number of bytes of "bytes" to append. */
+ Tcl_Obj *objPtr; /* Points to the object to append to. */
+ CONST char *bytes; /* String to append. */
+ int numBytes; /* Number of bytes of "bytes" to append. */
{
String *stringPtr;
int newLength, oldLength;
@@ -1434,12 +1469,11 @@ AppendUtfToUtfRep(objPtr, bytes, numBytes)
stringPtr = GET_STRING(objPtr);
if (newLength > (int) stringPtr->allocated) {
-
/*
- * There isn't currently enough space in the string representation
- * so allocate additional space. First, try to double the length
- * required. If that fails, try a more modest allocation. See the
- * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an
+ * There isn't currently enough space in the string representation so
+ * allocate additional space. First, try to double the length
+ * required. If that fails, try a more modest allocation. See the "TCL
+ * STRING GROWTH ALGORITHM" comment at the top of this file for an
* explanation of this growth algorithm.
*/
@@ -1452,10 +1486,10 @@ AppendUtfToUtfRep(objPtr, bytes, numBytes)
/*
* Invalidate the unicode data.
*/
-
+
stringPtr->numChars = -1;
stringPtr->hasUnicode = 0;
-
+
memcpy((VOID *) (objPtr->bytes + oldLength), (VOID *) bytes,
(size_t) numBytes);
objPtr->bytes[newLength] = 0;
@@ -1467,15 +1501,15 @@ AppendUtfToUtfRep(objPtr, bytes, numBytes)
*
* Tcl_AppendStringsToObjVA --
*
- * This procedure appends one or more null-terminated strings
- * to an object.
+ * This function appends one or more null-terminated strings to an
+ * object.
*
* Results:
* None.
*
* Side effects:
- * The contents of all the string arguments are appended to the
- * string representation of objPtr.
+ * The contents of all the string arguments are appended to the string
+ * representation of objPtr.
*
*----------------------------------------------------------------------
*/
@@ -1501,10 +1535,10 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
SetStringFromAny(NULL, objPtr);
/*
- * Figure out how much space is needed for all the strings, and
- * expand the string representation if it isn't big enough. If no
- * bytes would be appended, just return. Note that on some platforms
- * (notably OS/390) the argList is an array so we need to use memcpy.
+ * Figure out how much space is needed for all the strings, and expand the
+ * string representation if it isn't big enough. If no bytes would be
+ * appended, just return. Note that on some platforms (notably OS/390) the
+ * argList is an array so we need to use memcpy.
*/
nargs = 0;
@@ -1515,21 +1549,22 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
if (string == NULL) {
break;
}
- if (nargs >= nargs_space) {
- /*
- * Expand the args buffer
- */
- nargs_space += STATIC_LIST_SIZE;
- if (args == static_list) {
- args = (void *)ckalloc(nargs_space * sizeof(char *));
- for (i = 0; i < nargs; ++i) {
- args[i] = static_list[i];
- }
- } else {
- args = (void *)ckrealloc((void *)args,
+ if (nargs >= nargs_space) {
+ /*
+ * Expand the args buffer.
+ */
+
+ nargs_space += STATIC_LIST_SIZE;
+ if (args == static_list) {
+ args = (void *) ckalloc(nargs_space * sizeof(char *));
+ for (i = 0; i < nargs; ++i) {
+ args[i] = static_list[i];
+ }
+ } else {
+ args = (void *) ckrealloc((void *) args,
nargs_space * sizeof(char *));
- }
- }
+ }
+ }
newLength += strlen(string);
args[nargs++] = string;
}
@@ -1539,17 +1574,16 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
stringPtr = GET_STRING(objPtr);
if (oldLength + newLength > (int) stringPtr->allocated) {
-
/*
- * There isn't currently enough space in the string
- * representation, so allocate additional space. If the current
- * string representation isn't empty (i.e. it looks like we're
- * doing a series of appends) then try to allocate extra space to
- * accomodate future growth: first try to double the required memory;
- * if that fails, try a more modest allocation. See the "TCL STRING
- * GROWTH ALGORITHM" comment at the top of this file for an explanation
- * of this growth algorithm. Otherwise, if the current string
- * representation is empty, exactly enough memory is allocated.
+ * There isn't currently enough space in the string representation, so
+ * allocate additional space. If the current string representation
+ * isn't empty (i.e. it looks like we're doing a series of appends)
+ * then try to allocate extra space to accomodate future growth: first
+ * try to double the required memory; if that fails, try a more modest
+ * allocation. See the "TCL STRING GROWTH ALGORITHM" comment at the
+ * top of this file for an explanation of this growth algorithm.
+ * Otherwise, if the current string representation is empty, exactly
+ * enough memory is allocated.
*/
if (oldLength == 0) {
@@ -1558,20 +1592,20 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
attemptLength = 2 * (oldLength + newLength);
if (Tcl_AttemptSetObjLength(objPtr, attemptLength) == 0) {
attemptLength = oldLength + (2 * newLength) +
- TCL_GROWTH_MIN_ALLOC;
+ TCL_GROWTH_MIN_ALLOC;
Tcl_SetObjLength(objPtr, attemptLength);
}
}
}
/*
- * Make a second pass through the arguments, appending all the
- * strings to the object.
+ * Make a second pass through the arguments, appending all the strings to
+ * the object.
*/
dst = objPtr->bytes + oldLength;
for (i = 0; i < nargs; ++i) {
- string = args[i];
+ string = args[i];
if (string == NULL) {
break;
}
@@ -1583,10 +1617,10 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
}
/*
- * Add a null byte to terminate the string. However, be careful:
- * it's possible that the object is totally empty (if it was empty
- * originally and there was nothing to append). In this case dst is
- * NULL; just leave everything alone.
+ * Add a null byte to terminate the string. However, be careful: it's
+ * possible that the object is totally empty (if it was empty originally
+ * and there was nothing to append). In this case dst is NULL; just leave
+ * everything alone.
*/
if (dst != NULL) {
@@ -1594,14 +1628,13 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
}
objPtr->length = oldLength + newLength;
- done:
+ done:
/*
- * If we had to allocate a buffer from the heap,
- * free it now.
+ * If we had to allocate a buffer from the heap, free it now.
*/
-
+
if (args != static_list) {
- ckfree((void *)args);
+ ckfree((void *)args);
}
#undef STATIC_LIST_SIZE
}
@@ -1611,15 +1644,15 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
*
* Tcl_AppendStringsToObj --
*
- * This procedure appends one or more null-terminated strings
- * to an object.
+ * This function appends one or more null-terminated strings to an
+ * object.
*
* Results:
* None.
*
* Side effects:
- * The contents of all the string arguments are appended to the
- * string representation of objPtr.
+ * The contents of all the string arguments are appended to the string
+ * representation of objPtr.
*
*----------------------------------------------------------------------
*/
@@ -1641,7 +1674,7 @@ Tcl_AppendStringsToObj TCL_VARARGS_DEF(Tcl_Obj *,arg1)
* FillUnicodeRep --
*
* Populate the Unicode internal rep with the Unicode form of its string
- * rep. The object must alread have a "String" internal rep.
+ * rep. The object must alread have a "String" internal rep.
*
* Results:
* None.
@@ -1654,14 +1687,15 @@ Tcl_AppendStringsToObj TCL_VARARGS_DEF(Tcl_Obj *,arg1)
static void
FillUnicodeRep(objPtr)
- Tcl_Obj *objPtr; /* The object in which to fill the unicode rep. */
+ Tcl_Obj *objPtr; /* The object in which to fill the unicode
+ * rep. */
{
String *stringPtr;
size_t uallocated;
char *src, *srcEnd;
Tcl_UniChar *dst;
src = objPtr->bytes;
-
+
stringPtr = GET_STRING(objPtr);
if (stringPtr->numChars == -1) {
stringPtr->numChars = Tcl_NumUtfChars(src, objPtr->length);
@@ -1670,18 +1704,15 @@ FillUnicodeRep(objPtr)
uallocated = STRING_UALLOC(stringPtr->numChars);
if (uallocated > stringPtr->uallocated) {
-
/*
* If not enough space has been allocated for the unicode rep,
* reallocate the internal rep object.
- */
-
- /*
- * There isn't currently enough space in the Unicode
- * representation so allocate additional space. If the current
- * Unicode representation isn't empty (i.e. it looks like we've
- * done some appends) then overallocate the space so
- * that we won't have to do as much reallocation in the future.
+ *
+ * There isn't currently enough space in the Unicode representation so
+ * allocate additional space. If the current Unicode representation
+ * isn't empty (i.e. it looks like we've done some appends) then
+ * overallocate the space so that we won't have to do as much
+ * reallocation in the future.
*/
if (stringPtr->uallocated > 0) {
@@ -1695,13 +1726,13 @@ FillUnicodeRep(objPtr)
/*
* Convert src to Unicode and store the coverted data in "unicode".
*/
-
+
srcEnd = src + objPtr->length;
for (dst = stringPtr->unicode; src < srcEnd; dst++) {
src += TclUtfToUniChar(src, dst);
}
*dst = 0;
-
+
SET_STRING(objPtr, stringPtr);
}
@@ -1710,8 +1741,8 @@ FillUnicodeRep(objPtr)
*
* DupStringInternalRep --
*
- * Initialize the internal representation of a new Tcl_Obj to a
- * copy of the internal representation of an existing string object.
+ * Initialize the internal representation of a new Tcl_Obj to a copy of
+ * the internal representation of an existing string object.
*
* Results:
* None.
@@ -1725,27 +1756,27 @@ FillUnicodeRep(objPtr)
static void
DupStringInternalRep(srcPtr, copyPtr)
- register Tcl_Obj *srcPtr; /* Object with internal rep to copy. Must
- * have an internal rep of type "String". */
- register Tcl_Obj *copyPtr; /* Object with internal rep to set. Must
- * not currently have an internal rep.*/
+ register Tcl_Obj *srcPtr; /* Object with internal rep to copy. Must have
+ * an internal rep of type "String". */
+ register Tcl_Obj *copyPtr; /* Object with internal rep to set. Must not
+ * currently have an internal rep.*/
{
String *srcStringPtr = GET_STRING(srcPtr);
String *copyStringPtr = NULL;
/*
- * If the src obj is a string of 1-byte Utf chars, then copy the
- * string rep of the source object and create an "empty" Unicode
- * internal rep for the new object. Otherwise, copy Unicode
- * internal rep, and invalidate the string rep of the new object.
+ * If the src obj is a string of 1-byte Utf chars, then copy the string
+ * rep of the source object and create an "empty" Unicode internal rep for
+ * the new object. Otherwise, copy Unicode internal rep, and invalidate
+ * the string rep of the new object.
*/
-
+
if (srcStringPtr->hasUnicode == 0) {
- copyStringPtr = (String *) ckalloc(STRING_SIZE(STRING_UALLOC(0)));
+ copyStringPtr = (String *) ckalloc(STRING_SIZE(STRING_UALLOC(0)));
copyStringPtr->uallocated = STRING_UALLOC(0);
} else {
copyStringPtr = (String *) ckalloc(
- STRING_SIZE(srcStringPtr->uallocated));
+ STRING_SIZE(srcStringPtr->uallocated));
copyStringPtr->uallocated = srcStringPtr->uallocated;
memcpy((VOID *) copyStringPtr->unicode,
@@ -1758,9 +1789,9 @@ DupStringInternalRep(srcPtr, copyPtr)
copyStringPtr->allocated = srcStringPtr->allocated;
/*
- * Tricky point: the string value was copied by generic object
- * management code, so it doesn't contain any extra bytes that
- * might exist in the source object.
+ * Tricky point: the string value was copied by generic object management
+ * code, so it doesn't contain any extra bytes that might exist in the
+ * source object.
*/
copyStringPtr->allocated = copyPtr->length;
@@ -1780,8 +1811,8 @@ DupStringInternalRep(srcPtr, copyPtr)
* This operation always succeeds and returns TCL_OK.
*
* Side effects:
- * Any old internal reputation for objPtr is freed and the
- * internal representation is set to "String".
+ * Any old internal reputation for objPtr is freed and the internal
+ * representation is set to "String".
*
*----------------------------------------------------------------------
*/
@@ -1792,9 +1823,9 @@ SetStringFromAny(interp, objPtr)
register Tcl_Obj *objPtr; /* The object to convert. */
{
/*
- * The Unicode object is optimized for the case where each UTF char
- * in a string is only one byte. In this case, we store the value of
- * numChars, but we don't copy the bytes to the unicodeObj->unicode.
+ * The Unicode object is optimized for the case where each UTF char in a
+ * string is only one byte. In this case, we store the value of numChars,
+ * but we don't copy the bytes to the unicodeObj->unicode.
*/
if (objPtr->typePtr != &tclStringType) {
@@ -1818,8 +1849,8 @@ SetStringFromAny(interp, objPtr)
stringPtr->hasUnicode = 0;
if (objPtr->bytes != NULL) {
- stringPtr->allocated = objPtr->length;
- objPtr->bytes[objPtr->length] = 0;
+ stringPtr->allocated = objPtr->length;
+ objPtr->bytes[objPtr->length] = 0;
} else {
objPtr->length = 0;
}
@@ -1840,8 +1871,8 @@ SetStringFromAny(interp, objPtr)
* None.
*
* Side effects:
- * The object's string may be set by converting its Unicode
- * represention to UTF format.
+ * The object's string may be set by converting its Unicode represention
+ * to UTF format.
*
*----------------------------------------------------------------------
*/
@@ -1858,12 +1889,10 @@ UpdateStringOfString(objPtr)
stringPtr = GET_STRING(objPtr);
if ((objPtr->bytes == NULL) || (stringPtr->allocated == 0)) {
-
if (stringPtr->numChars <= 0) {
-
/*
- * If there is no Unicode rep, or the string has 0 chars,
- * then set the string rep to an empty string.
+ * If there is no Unicode rep, or the string has 0 chars, then set
+ * the string rep to an empty string.
*/
objPtr->bytes = tclEmptyStringRep;
@@ -1874,15 +1903,15 @@ UpdateStringOfString(objPtr)
unicode = stringPtr->unicode;
/*
- * Translate the Unicode string to UTF. "size" will hold the
- * amount of space the UTF string needs.
+ * Translate the Unicode string to UTF. "size" will hold the amount of
+ * space the UTF string needs.
*/
size = 0;
for (i = 0; i < stringPtr->numChars; i++) {
size += Tcl_UniCharToUtf((int) unicode[i], dummy);
}
-
+
dst = (char *) ckalloc((unsigned) (size + 1));
objPtr->bytes = dst;
objPtr->length = size;
@@ -1901,14 +1930,14 @@ UpdateStringOfString(objPtr)
*
* FreeStringInternalRep --
*
- * Deallocate the storage associated with a String data object's
- * internal representation.
+ * Deallocate the storage associated with a String data object's internal
+ * representation.
*
* Results:
* None.
*
* Side effects:
- * Frees memory.
+ * Frees memory.
*
*----------------------------------------------------------------------
*/
@@ -1919,3 +1948,11 @@ FreeStringInternalRep(objPtr)
{
ckfree((char *) GET_STRING(objPtr));
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index c03cc9e..f36d0d7 100755
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -2,24 +2,24 @@
* tclThreadAlloc.c --
*
* This is a very fast storage allocator for used with threads (designed
- * avoid lock contention). The basic strategy is to allocate memory in
+ * avoid lock contention). The basic strategy is to allocate memory in
* fixed size blocks from block caches.
*
* The Initial Developer of the Original Code is America Online, Inc.
* Portions created by AOL are Copyright (C) 1999 America Online, Inc.
*
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclThreadAlloc.c,v 1.16 2005/05/10 18:34:50 kennykb Exp $
+ * RCS: @(#) $Id: tclThreadAlloc.c,v 1.17 2005/07/24 22:56:44 dkf Exp $
*/
#include "tclInt.h"
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
/*
- * If range checking is enabled, an additional byte will be allocated
- * to store the magic number at the end of the requested memory.
+ * If range checking is enabled, an additional byte will be allocated to store
+ * the magic number at the end of the requested memory.
*/
#ifndef RCHECK
@@ -31,33 +31,32 @@
#endif
/*
- * The following define the number of Tcl_Obj's to allocate/move
- * at a time and the high water mark to prune a per-thread cache.
- * On a 32 bit system, sizeof(Tcl_Obj) = 24 so 800 * 24 = ~16k.
+ * The following define the number of Tcl_Obj's to allocate/move at a time and
+ * the high water mark to prune a per-thread cache. On a 32 bit system,
+ * sizeof(Tcl_Obj) = 24 so 800 * 24 = ~16k.
*/
-#define NOBJALLOC 800
+#define NOBJALLOC 800
#define NOBJHIGH 1200
/*
- * The following defines the number of buckets in the bucket
- * cache and those block sizes from (1<<4) to (1<<(3+NBUCKETS))
+ * The following defines the number of buckets in the bucket cache and those
+ * block sizes from (1<<4) to (1<<(3+NBUCKETS))
*/
-#define NBUCKETS 11
-#define MAXALLOC 16284
+#define NBUCKETS 11
+#define MAXALLOC 16284
/*
- * The following union stores accounting information for
- * each block including two small magic numbers and
- * a bucket number when in use or a next pointer when
- * free. The original requested size (not including
- * the Block overhead) is also maintained.
+ * The following union stores accounting information for each block including
+ * two small magic numbers and a bucket number when in use or a next pointer
+ * when free. The original requested size (not including the Block overhead)
+ * is also maintained.
*/
typedef struct Block {
union {
- struct Block *next; /* Next in free list. */
+ struct Block *next; /* Next in free list. */
struct {
unsigned char magic1; /* First magic number. */
unsigned char bucket; /* Bucket block allocated from. */
@@ -65,7 +64,7 @@ typedef struct Block {
unsigned char magic2; /* Second magic number. */
} s;
} u;
- size_t reqSize; /* Requested allocation size. */
+ size_t reqSize; /* Requested allocation size. */
} Block;
#define nextBlock u.next
#define sourceBucket u.s.bucket
@@ -74,48 +73,47 @@ typedef struct Block {
#define MAGIC 0xEF
/*
- * The following structure defines a bucket of blocks with
- * various accounting and statistics information.
+ * The following structure defines a bucket of blocks with various accounting
+ * and statistics information.
*/
typedef struct Bucket {
- Block *firstPtr; /* First block available */
- int numFree; /* Number of blocks available */
+ Block *firstPtr; /* First block available */
+ int numFree; /* Number of blocks available */
/* All fields below for accounting only */
- int numRemoves; /* Number of removes from bucket */
- int numInserts; /* Number of inserts into bucket */
- int numWaits; /* Number of waits to acquire a lock */
- int numLocks; /* Number of locks acquired */
- int totalAssigned; /* Total space assigned to bucket */
+ int numRemoves; /* Number of removes from bucket */
+ int numInserts; /* Number of inserts into bucket */
+ int numWaits; /* Number of waits to acquire a lock */
+ int numLocks; /* Number of locks acquired */
+ int totalAssigned; /* Total space assigned to bucket */
} Bucket;
/*
- * The following structure defines a cache of buckets and objs, of
- * which there will be (at most) one per thread.
+ * The following structure defines a cache of buckets and objs, of which there
+ * will be (at most) one per thread.
*/
typedef struct Cache {
- struct Cache *nextPtr; /* Linked list of cache entries */
- Tcl_ThreadId owner; /* Which thread's cache is this? */
- Tcl_Obj *firstObjPtr; /* List of free objects for thread */
- int numObjects; /* Number of objects for thread */
- int totalAssigned; /* Total space assigned to thread */
- Bucket buckets[NBUCKETS]; /* The buckets for this thread */
+ struct Cache *nextPtr; /* Linked list of cache entries */
+ Tcl_ThreadId owner; /* Which thread's cache is this? */
+ Tcl_Obj *firstObjPtr; /* List of free objects for thread */
+ int numObjects; /* Number of objects for thread */
+ int totalAssigned; /* Total space assigned to thread */
+ Bucket buckets[NBUCKETS]; /* The buckets for this thread */
} Cache;
/*
- * The following array specifies various per-bucket limits and locks.
- * The values are statically initialized to avoid calculating them
- * repeatedly.
+ * The following array specifies various per-bucket limits and locks. The
+ * values are statically initialized to avoid calculating them repeatedly.
*/
static struct {
- size_t blockSize; /* Bucket blocksize. */
- int maxBlocks; /* Max blocks before move to share. */
- int numMove; /* Num blocks to move to share. */
- Tcl_Mutex *lockPtr; /* Share bucket lock. */
+ size_t blockSize; /* Bucket blocksize. */
+ int maxBlocks; /* Max blocks before move to share. */
+ int numMove; /* Num blocks to move to share. */
+ Tcl_Mutex *lockPtr; /* Share bucket lock. */
} bucketInfo[NBUCKETS] = {
{ 16, 1024, 512, NULL},
{ 32, 512, 256, NULL},
@@ -146,8 +144,7 @@ static void MoveObjs _ANSI_ARGS_((Cache *fromPtr, Cache *toPtr,
int numMove));
/*
- * Local variables defined in this file and initialized at
- * startup.
+ * Local variables defined in this file and initialized at startup.
*/
static Tcl_Mutex *listLockPtr;
@@ -306,10 +303,9 @@ TclpAlloc(reqSize)
}
/*
- * Increment the requested size to include room for
- * the Block structure. Call malloc() directly if the
- * required amount is greater than the largest block,
- * otherwise pop the smallest block large enough,
+ * Increment the requested size to include room for the Block structure.
+ * Call malloc() directly if the required amount is greater than the
+ * largest block, otherwise pop the smallest block large enough,
* allocating more blocks if necessary.
*/
@@ -377,10 +373,9 @@ TclpFree(ptr)
}
/*
- * Get the block back from the user pointer and call system free
- * directly for large blocks. Otherwise, push the block back on
- * the bucket and move blocks to the shared cache if there are now
- * too many free.
+ * Get the block back from the user pointer and call system free directly
+ * for large blocks. Otherwise, push the block back on the bucket and move
+ * blocks to the shared cache if there are now too many free.
*/
blockPtr = Ptr2Block(ptr);
@@ -390,11 +385,13 @@ TclpFree(ptr)
free(blockPtr);
return;
}
+
cachePtr->buckets[bucket].totalAssigned -= blockPtr->reqSize;
blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr;
cachePtr->buckets[bucket].firstPtr = blockPtr;
++cachePtr->buckets[bucket].numFree;
++cachePtr->buckets[bucket].numInserts;
+
if (cachePtr != sharedPtr &&
cachePtr->buckets[bucket].numFree > bucketInfo[bucket].maxBlocks) {
PutBlocks(cachePtr, bucket, bucketInfo[bucket].numMove);
@@ -437,10 +434,9 @@ TclpRealloc(ptr, reqSize)
}
/*
- * If the block is not a system block and fits in place,
- * simply return the existing pointer. Otherwise, if the block
- * is a system block and the new size would also require a system
- * block, call realloc() directly.
+ * If the block is not a system block and fits in place, simply return the
+ * existing pointer. Otherwise, if the block is a system block and the new
+ * size would also require a system block, call realloc() directly.
*/
blockPtr = Ptr2Block(ptr);
@@ -496,8 +492,8 @@ TclpRealloc(ptr, reqSize)
* Pointer to uninitialized Tcl_Obj.
*
* Side effects:
- * May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's
- * if list is empty.
+ * May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's if
+ * list is empty.
*
*----------------------------------------------------------------------
*/
@@ -506,20 +502,20 @@ Tcl_Obj *
TclThreadAllocObj(void)
{
register Cache *cachePtr = TclpGetAllocCache();
- register int numMove;
register Tcl_Obj *objPtr;
- Tcl_Obj *newObjsPtr;
if (cachePtr == NULL) {
cachePtr = GetCache();
}
/*
- * Get this thread's obj list structure and move
- * or allocate new objs if necessary.
+ * Get this thread's obj list structure and move or allocate new objs if
+ * necessary.
*/
if (cachePtr->numObjects == 0) {
+ register int numMove;
+
Tcl_MutexLock(objLockPtr);
numMove = sharedPtr->numObjects;
if (numMove > 0) {
@@ -530,6 +526,8 @@ TclThreadAllocObj(void)
}
Tcl_MutexUnlock(objLockPtr);
if (cachePtr->numObjects == 0) {
+ Tcl_Obj *newObjsPtr;
+
cachePtr->numObjects = numMove = NOBJALLOC;
newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove);
if (newObjsPtr == NULL) {
@@ -564,8 +562,7 @@ TclThreadAllocObj(void)
* None.
*
* Side effects:
- * May move free Tcl_Obj's to shared list upon hitting high
- * water mark.
+ * May move free Tcl_Obj's to shared list upon hitting high water mark.
*
*----------------------------------------------------------------------
*/
@@ -589,8 +586,8 @@ TclThreadFreeObj(objPtr)
++cachePtr->numObjects;
/*
- * If the number of free objects has exceeded the high
- * water mark, move some blocks to the shared list.
+ * If the number of free objects has exceeded the high water mark, move
+ * some blocks to the shared list.
*/
if (cachePtr->numObjects > NOBJHIGH) {
@@ -679,9 +676,8 @@ MoveObjs(fromPtr, toPtr, numMove)
fromPtr->numObjects -= numMove;
/*
- * Find the last object to be moved; set the next one
- * (the first one not to be moved) as the first object
- * in the 'from' cache.
+ * Find the last object to be moved; set the next one (the first one not
+ * to be moved) as the first object in the 'from' cache.
*/
while (--numMove) {
@@ -690,8 +686,8 @@ MoveObjs(fromPtr, toPtr, numMove)
fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr;
/*
- * Move all objects as a block - they are already linked to
- * each other, we just have to update the first and last.
+ * Move all objects as a block - they are already linked to each other, we
+ * just have to update the first and last.
*/
objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr;
@@ -764,8 +760,8 @@ Ptr2Block(ptr)
* None.
*
* Side effects:
- * Lock activity and contention are monitored globally and on
- * a per-cache basis.
+ * Lock activity and contention are monitored globally and on a per-cache
+ * basis.
*
*----------------------------------------------------------------------
*/
@@ -821,8 +817,8 @@ PutBlocks(cachePtr, bucket, numMove)
register int n = numMove;
/*
- * Before acquiring the lock, walk the block list to find
- * the last block to be moved.
+ * Before acquiring the lock, walk the block list to find the last block
+ * to be moved.
*/
firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr;
@@ -833,8 +829,8 @@ PutBlocks(cachePtr, bucket, numMove)
cachePtr->buckets[bucket].numFree -= numMove;
/*
- * Aquire the lock and place the list of blocks at the front
- * of the shared cache bucket.
+ * Aquire the lock and place the list of blocks at the front of the shared
+ * cache bucket.
*/
LockBucket(cachePtr, bucket);
@@ -867,13 +863,12 @@ GetBlocks(cachePtr, bucket)
{
register Block *blockPtr;
register int n;
- register size_t size;
/*
- * First, atttempt to move blocks from the shared cache. Note
- * the potentially dirty read of numFree before acquiring the lock
- * which is a slight performance enhancement. The value is
- * verified after the lock is actually acquired.
+ * First, atttempt to move blocks from the shared cache. Note the
+ * potentially dirty read of numFree before acquiring the lock which is a
+ * slight performance enhancement. The value is verified after the lock is
+ * actually acquired.
*/
if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].numFree > 0) {
@@ -881,8 +876,8 @@ GetBlocks(cachePtr, bucket)
if (sharedPtr->buckets[bucket].numFree > 0) {
/*
- * Either move the entire list or walk the list to find
- * the last block to move.
+ * Either move the entire list or walk the list to find the last
+ * block to move.
*/
n = bucketInfo[bucket].numMove;
@@ -909,10 +904,11 @@ GetBlocks(cachePtr, bucket)
}
if (cachePtr->buckets[bucket].numFree == 0) {
+ register size_t size;
/*
- * If no blocks could be moved from shared, first look for a
- * larger block in this cache to split up.
+ * If no blocks could be moved from shared, first look for a larger
+ * block in this cache to split up.
*/
blockPtr = NULL;
@@ -962,8 +958,8 @@ GetBlocks(cachePtr, bucket)
*
* TclFinalizeThreadAlloc --
*
- * This procedure is used to destroy all private resources used in
- * this file.
+ * This procedure is used to destroy all private resources used in this
+ * file.
*
* Results:
* None.
@@ -979,7 +975,7 @@ TclFinalizeThreadAlloc()
{
int i;
for (i = 0; i < NBUCKETS; ++i) {
- TclpFreeAllocMutex(bucketInfo[i].lockPtr);
+ TclpFreeAllocMutex(bucketInfo[i].lockPtr);
bucketInfo[i].lockPtr = NULL;
}
@@ -993,14 +989,13 @@ TclFinalizeThreadAlloc()
}
#else
-
/*
*----------------------------------------------------------------------
*
* TclFinalizeThreadAlloc --
*
- * This procedure is used to destroy all private resources used in
- * this file.
+ * This procedure is used to destroy all private resources used in this
+ * file.
*
* Results:
* None.
@@ -1016,5 +1011,12 @@ TclFinalizeThreadAlloc()
{
Tcl_Panic("TclFinalizeThreadAlloc called when threaded memory allocator not in use.");
}
-
#endif /* TCL_THREADS */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index 85e8c0c..ce07825 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -1,4 +1,4 @@
-/*
+/*
* tclTimer.c --
*
* This file provides timer event management facilities for Tcl,
@@ -6,76 +6,75 @@
*
* Copyright (c) 1997 by Sun Microsystems, Inc.
*
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTimer.c,v 1.16 2005/06/17 14:26:15 dkf Exp $
+ * RCS: @(#) $Id: tclTimer.c,v 1.17 2005/07/24 22:56:44 dkf Exp $
*/
#include "tclInt.h"
/*
* For each timer callback that's pending there is one record of the following
- * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained
+ * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained
* together in a list sorted by time (earliest event first).
*/
typedef struct TimerHandler {
- Tcl_Time time; /* When timer is to fire. */
- Tcl_TimerProc *proc; /* Procedure to call. */
- ClientData clientData; /* Argument to pass to proc. */
- Tcl_TimerToken token; /* Identifies handler so it can be
- * deleted. */
- struct TimerHandler *nextPtr; /* Next event in queue, or NULL for
- * end of queue. */
+ Tcl_Time time; /* When timer is to fire. */
+ Tcl_TimerProc *proc; /* Function to call. */
+ ClientData clientData; /* Argument to pass to proc. */
+ Tcl_TimerToken token; /* Identifies handler so it can be deleted. */
+ struct TimerHandler *nextPtr;
+ /* Next event in queue, or NULL for end of
+ * queue. */
} TimerHandler;
/*
- * The data structure below is used by the "after" command to remember
- * the command to be executed later. All of the pending "after" commands
- * for an interpreter are linked together in a list.
+ * The data structure below is used by the "after" command to remember the
+ * command to be executed later. All of the pending "after" commands for an
+ * interpreter are linked together in a list.
*/
typedef struct AfterInfo {
struct AfterAssocData *assocPtr;
- /* Pointer to the "tclAfter" assocData for
- * the interp in which command will be
+ /* Pointer to the "tclAfter" assocData for the
+ * interp in which command will be
* executed. */
Tcl_Obj *commandPtr; /* Command to execute. */
- int id; /* Integer identifier for command; used to
+ int id; /* Integer identifier for command; used to
* cancel it. */
- Tcl_TimerToken token; /* Used to cancel the "after" command. NULL
- * means that the command is run as an
- * idle handler rather than as a timer
- * handler. NULL means this is an "after
- * idle" handler rather than a
- * timer handler. */
+ Tcl_TimerToken token; /* Used to cancel the "after" command. NULL
+ * means that the command is run as an idle
+ * handler rather than as a timer handler.
+ * NULL means this is an "after idle" handler
+ * rather than a timer handler. */
struct AfterInfo *nextPtr; /* Next in list of all "after" commands for
* this interpreter. */
} AfterInfo;
/*
- * One of the following structures is associated with each interpreter
- * for which an "after" command has ever been invoked. A pointer to
- * this structure is stored in the AssocData for the "tclAfter" key.
+ * One of the following structures is associated with each interpreter for
+ * which an "after" command has ever been invoked. A pointer to this structure
+ * is stored in the AssocData for the "tclAfter" key.
*/
typedef struct AfterAssocData {
Tcl_Interp *interp; /* The interpreter for which this data is
* registered. */
- AfterInfo *firstAfterPtr; /* First in list of all "after" commands
- * still pending for this interpreter, or
- * NULL if none. */
+ AfterInfo *firstAfterPtr; /* First in list of all "after" commands still
+ * pending for this interpreter, or NULL if
+ * none. */
} AfterAssocData;
/*
- * There is one of the following structures for each of the
- * handlers declared in a call to Tcl_DoWhenIdle. All of the
- * currently-active handlers are linked together into a list.
+ * There is one of the following structures for each of the handlers declared
+ * in a call to Tcl_DoWhenIdle. All of the currently-active handlers are
+ * linked together into a list.
*/
typedef struct IdleHandler {
- Tcl_IdleProc (*proc); /* Procedure to call. */
+ Tcl_IdleProc (*proc); /* Function to call. */
ClientData clientData; /* Value to pass to proc. */
int generation; /* Used to distinguish older handlers from
* recently-created ones. */
@@ -83,37 +82,55 @@ typedef struct IdleHandler {
} IdleHandler;
/*
- * The timer and idle queues are per-thread because they are associated
- * with the notifier, which is also per-thread.
+ * The timer and idle queues are per-thread because they are associated with
+ * the notifier, which is also per-thread.
*
- * All static variables used in this file are collected into a single
- * instance of the following structure. For multi-threaded implementations,
- * there is one instance of this structure for each thread.
+ * All static variables used in this file are collected into a single instance
+ * of the following structure. For multi-threaded implementations, there is
+ * one instance of this structure for each thread.
*
- * Notice that different structures with the same name appear in other
- * files. The structure defined below is used in this file only.
+ * Notice that different structures with the same name appear in other files.
+ * The structure defined below is used in this file only.
*/
typedef struct ThreadSpecificData {
TimerHandler *firstTimerHandlerPtr; /* First event in queue. */
- int lastTimerId; /* Timer identifier of most recently
- * created timer. */
+ int lastTimerId; /* Timer identifier of most recently created
+ * timer. */
int timerPending; /* 1 if a timer event is in the queue. */
IdleHandler *idleList; /* First in list of all idle handlers. */
IdleHandler *lastIdlePtr; /* Last in list (or NULL for empty list). */
- int idleGeneration; /* Used to fill in the "generation" fields
- * of IdleHandler structures. Increments
- * each time Tcl_DoOneEvent starts calling
- * idle handlers, so that all old handlers
- * can be called without calling any of the
- * new ones created by old ones. */
+ int idleGeneration; /* Used to fill in the "generation" fields of
+ * IdleHandler structures. Increments each
+ * time Tcl_DoOneEvent starts calling idle
+ * handlers, so that all old handlers can be
+ * called without calling any of the new ones
+ * created by old ones. */
int afterId; /* For unique identifiers of after events. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
- * Prototypes for procedures referenced only in this file:
+ * Helper macros for working with times. TCL_TIME_BEFORE encodes how to write
+ * the ordering relation on (normalized) times, and TCL_TIME_DIFF_MS computes
+ * the number of milliseconds difference between two times. Both macros use
+ * both of their arguments multiple times, so make sure they are cheap and
+ * side-effect free. The "prototypes" for these macros are:
+ *
+ * static int TCL_TIME_BEFORE(Tcl_Time t1, Tcl_Time t2);
+ * static long TCL_TIME_DIFF_MS(Tcl_Time t1, Tcl_Time t2);
+ */
+
+#define TCL_TIME_BEFORE(t1, t2) \
+ (((t1).sec<(t2).sec) || ((t1).sec==(t2).sec && (t1).usec<(t2).usec))
+
+#define TCL_TIME_DIFF_MS(t1, t2) \
+ (1000*((long)(t1).sec - (long)(t2).sec) + \
+ ((long)(t1).usec - (long)(t2).usec)/1000)
+
+/*
+ * Prototypes for functions referenced only in this file:
*/
static void AfterCleanupProc _ANSI_ARGS_((ClientData clientData,
@@ -151,8 +168,8 @@ static void TimerSetupProc _ANSI_ARGS_((ClientData clientData,
static ThreadSpecificData *
InitTimer()
{
- ThreadSpecificData *tsdPtr =
- (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+ TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -167,8 +184,8 @@ InitTimer()
*
* TimerExitProc --
*
- * This function is call at exit or unload time to remove the
- * timer and idle event sources.
+ * This function is call at exit or unload time to remove the timer and
+ * idle event sources.
*
* Results:
* None.
@@ -183,12 +200,13 @@ static void
TimerExitProc(clientData)
ClientData clientData; /* Not used. */
{
- ThreadSpecificData *tsdPtr =
- (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+ TclThreadDataKeyGet(&dataKey);
Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL);
if (tsdPtr != NULL) {
register TimerHandler *timerHandlerPtr;
+
timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
while (timerHandlerPtr != NULL) {
tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
@@ -203,25 +221,24 @@ TimerExitProc(clientData)
*
* Tcl_CreateTimerHandler --
*
- * Arrange for a given procedure to be invoked at a particular
- * time in the future.
+ * Arrange for a given function to be invoked at a particular time in the
+ * future.
*
* Results:
- * The return value is a token for the timer event, which
- * may be used to delete the event before it fires.
+ * The return value is a token for the timer event, which may be used to
+ * delete the event before it fires.
*
* Side effects:
- * When milliseconds have elapsed, proc will be invoked
- * exactly once.
+ * When milliseconds have elapsed, proc will be invoked exactly once.
*
*--------------------------------------------------------------
*/
Tcl_TimerToken
Tcl_CreateTimerHandler(milliseconds, proc, clientData)
- int milliseconds; /* How many milliseconds to wait
- * before invoking proc. */
- Tcl_TimerProc *proc; /* Procedure to invoke. */
+ int milliseconds; /* How many milliseconds to wait before
+ * invoking proc. */
+ Tcl_TimerProc *proc; /* Function to invoke. */
ClientData clientData; /* Arbitrary data to pass to proc. */
{
Tcl_Time time;
@@ -245,12 +262,12 @@ Tcl_CreateTimerHandler(milliseconds, proc, clientData)
*
* TclCreateAbsoluteTimerHandler --
*
- * Arrange for a given procedure to be invoked at a particular
- * time in the future.
+ * Arrange for a given function to be invoked at a particular time in the
+ * future.
*
* Results:
- * The return value is a token for the timer event, which
- * may be used to delete the event before it fires.
+ * The return value is a token for the timer event, which may be used to
+ * delete the event before it fires.
*
* Side effects:
* When the time in timePtr has been reached, proc will be invoked
@@ -288,9 +305,7 @@ TclCreateAbsoluteTimerHandler(timePtr, proc, clientData)
for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
- if ((tPtr2->time.sec > timerHandlerPtr->time.sec)
- || ((tPtr2->time.sec == timerHandlerPtr->time.sec)
- && (tPtr2->time.usec > timerHandlerPtr->time.usec))) {
+ if (TCL_TIME_BEFORE(timerHandlerPtr->time, tPtr2->time)) {
break;
}
}
@@ -317,10 +332,9 @@ TclCreateAbsoluteTimerHandler(timePtr, proc, clientData)
* None.
*
* Side effects:
- * Destroy the timer callback identified by TimerToken,
- * so that its associated procedure will not be called.
- * If the callback has already fired, or if the given
- * token doesn't exist, then nothing happens.
+ * Destroy the timer callback identified by TimerToken, so that its
+ * associated function will not be called. If the callback has already
+ * fired, or if the given token doesn't exist, then nothing happens.
*
*--------------------------------------------------------------
*/
@@ -355,9 +369,9 @@ Tcl_DeleteTimerHandler(token)
*
* TimerSetupProc --
*
- * This function is called by Tcl_DoOneEvent to setup the timer
- * event source for before blocking. This routine checks both the
- * idle and after timer lists.
+ * This function is called by Tcl_DoOneEvent to setup the timer event
+ * source for before blocking. This routine checks both the idle and
+ * after timer lists.
*
* Results:
* None.
@@ -405,7 +419,7 @@ TimerSetupProc(data, flags)
} else {
return;
}
-
+
Tcl_SetMaxBlockTime(&blockTime);
}
@@ -414,9 +428,9 @@ TimerSetupProc(data, flags)
*
* TimerCheckProc --
*
- * This function is called by Tcl_DoOneEvent to check the timer
- * event source for events. This routine checks both the
- * idle and after timer lists.
+ * This function is called by Tcl_DoOneEvent to check the timer event
+ * source for events. This routine checks both the idle and after timer
+ * lists.
*
* Results:
* None.
@@ -473,19 +487,18 @@ TimerCheckProc(data, flags)
*
* TimerHandlerEventProc --
*
- * This procedure is called by Tcl_ServiceEvent when a timer event
- * reaches the front of the event queue. This procedure handles
- * the event by invoking the callbacks for all timers that are
- * ready.
+ * This function is called by Tcl_ServiceEvent when a timer event reaches
+ * the front of the event queue. This function handles the event by
+ * invoking the callbacks for all timers that are ready.
*
* Results:
- * Returns 1 if the event was handled, meaning it should be removed
- * from the queue. Returns 0 if the event was not handled, meaning
- * it should stay on the queue. The only time the event isn't
- * handled is if the TCL_TIMER_EVENTS flag bit isn't set.
+ * Returns 1 if the event was handled, meaning it should be removed from
+ * the queue. Returns 0 if the event was not handled, meaning it should
+ * stay on the queue. The only time the event isn't handled is if the
+ * TCL_TIMER_EVENTS flag bit isn't set.
*
* Side effects:
- * Whatever the timer handler callback procedures do.
+ * Whatever the timer handler callback functions do.
*
*----------------------------------------------------------------------
*/
@@ -493,8 +506,8 @@ TimerCheckProc(data, flags)
static int
TimerHandlerEventProc(evPtr, flags)
Tcl_Event *evPtr; /* Event to service. */
- int flags; /* Flags that indicate what events to
- * handle, such as TCL_FILE_EVENTS. */
+ int flags; /* Flags that indicate what events to handle,
+ * such as TCL_FILE_EVENTS. */
{
TimerHandler *timerHandlerPtr, **nextPtrPtr;
Tcl_Time time;
@@ -502,9 +515,9 @@ TimerHandlerEventProc(evPtr, flags)
ThreadSpecificData *tsdPtr = InitTimer();
/*
- * Do nothing if timers aren't enabled. This leaves the event on the
- * queue, so we will get to it as soon as ServiceEvents() is called
- * with timers enabled.
+ * Do nothing if timers aren't enabled. This leaves the event on the
+ * queue, so we will get to it as soon as ServiceEvents() is called with
+ * timers enabled.
*/
if (!(flags & TCL_TIMER_EVENTS)) {
@@ -512,30 +525,28 @@ TimerHandlerEventProc(evPtr, flags)
}
/*
- * The code below is trickier than it may look, for the following
- * reasons:
+ * The code below is trickier than it may look, for the following reasons:
*
- * 1. New handlers can get added to the list while the current
- * one is being processed. If new ones get added, we don't
- * want to process them during this pass through the list to avoid
- * starving other event sources. This is implemented using the
- * token number in the handler: new handlers will have a
- * newer token than any of the ones currently on the list.
- * 2. The handler can call Tcl_DoOneEvent, so we have to remove
- * the handler from the list before calling it. Otherwise an
- * infinite loop could result.
- * 3. Tcl_DeleteTimerHandler can be called to remove an element from
- * the list while a handler is executing, so the list could
- * change structure during the call.
- * 4. Because we only fetch the current time before entering the loop,
- * the only way a new timer will even be considered runnable is if
- * its expiration time is within the same millisecond as the
- * current time. This is fairly likely on Windows, since it has
- * a course granularity clock. Since timers are placed
- * on the queue in time order with the most recently created
- * handler appearing after earlier ones with the same expiration
- * time, we don't have to worry about newer generation timers
- * appearing before later ones.
+ * 1. New handlers can get added to the list while the current one is
+ * being processed. If new ones get added, we don't want to process
+ * them during this pass through the list to avoid starving other event
+ * sources. This is implemented using the token number in the handler:
+ * new handlers will have a newer token than any of the ones currently
+ * on the list.
+ * 2. The handler can call Tcl_DoOneEvent, so we have to remove the
+ * handler from the list before calling it. Otherwise an infinite loop
+ * could result.
+ * 3. Tcl_DeleteTimerHandler can be called to remove an element from the
+ * list while a handler is executing, so the list could change
+ * structure during the call.
+ * 4. Because we only fetch the current time before entering the loop, the
+ * only way a new timer will even be considered runnable is if its
+ * expiration time is within the same millisecond as the current time.
+ * This is fairly likely on Windows, since it has a course granularity
+ * clock. Since timers are placed on the queue in time order with the
+ * most recently created handler appearing after earlier ones with the
+ * same expiration time, we don't have to worry about newer generation
+ * timers appearing before later ones.
*/
tsdPtr->timerPending = 0;
@@ -547,10 +558,8 @@ TimerHandlerEventProc(evPtr, flags)
if (timerHandlerPtr == NULL) {
break;
}
-
- if ((timerHandlerPtr->time.sec > time.sec)
- || ((timerHandlerPtr->time.sec == time.sec)
- && (timerHandlerPtr->time.usec > time.usec))) {
+
+ if (TCL_TIME_BEFORE(time, timerHandlerPtr->time)) {
break;
}
@@ -563,8 +572,8 @@ TimerHandlerEventProc(evPtr, flags)
}
/*
- * Remove the handler from the queue before invoking it,
- * to avoid potential reentrancy problems.
+ * Remove the handler from the queue before invoking it, to avoid
+ * potential reentrancy problems.
*/
(*nextPtrPtr) = timerHandlerPtr->nextPtr;
@@ -580,23 +589,23 @@ TimerHandlerEventProc(evPtr, flags)
*
* Tcl_DoWhenIdle --
*
- * Arrange for proc to be invoked the next time the system is
- * idle (i.e., just before the next time that Tcl_DoOneEvent
- * would have to wait for something to happen).
+ * Arrange for proc to be invoked the next time the system is idle (i.e.,
+ * just before the next time that Tcl_DoOneEvent would have to wait for
+ * something to happen).
*
* Results:
* None.
*
* Side effects:
- * Proc will eventually be called, with clientData as argument.
- * See the manual entry for details.
+ * Proc will eventually be called, with clientData as argument. See the
+ * manual entry for details.
*
*--------------------------------------------------------------
*/
void
Tcl_DoWhenIdle(proc, clientData)
- Tcl_IdleProc *proc; /* Procedure to invoke. */
+ Tcl_IdleProc *proc; /* Function to invoke. */
ClientData clientData; /* Arbitrary value to pass to proc. */
{
register IdleHandler *idlePtr;
@@ -625,22 +634,22 @@ Tcl_DoWhenIdle(proc, clientData)
*
* Tcl_CancelIdleCall --
*
- * If there are any when-idle calls requested to a given procedure
- * with given clientData, cancel all of them.
+ * If there are any when-idle calls requested to a given function with
+ * given clientData, cancel all of them.
*
* Results:
* None.
*
* Side effects:
- * If the proc/clientData combination were on the when-idle list,
- * they are removed so that they will never be called.
+ * If the proc/clientData combination were on the when-idle list, they
+ * are removed so that they will never be called.
*
*----------------------------------------------------------------------
*/
void
Tcl_CancelIdleCall(proc, clientData)
- Tcl_IdleProc *proc; /* Procedure that was previously registered. */
+ Tcl_IdleProc *proc; /* Function that was previously registered. */
ClientData clientData; /* Arbitrary value to pass to proc. */
{
register IdleHandler *idlePtr, *prevPtr;
@@ -672,14 +681,13 @@ Tcl_CancelIdleCall(proc, clientData)
*
* TclServiceIdle --
*
- * This procedure is invoked by the notifier when it becomes
- * idle. It will invoke all idle handlers that are present at
- * the time the call is invoked, but not those added during idle
- * processing.
+ * This function is invoked by the notifier when it becomes idle. It will
+ * invoke all idle handlers that are present at the time the call is
+ * invoked, but not those added during idle processing.
*
* Results:
- * The return value is 1 if TclServiceIdle found something to
- * do, otherwise return value is 0.
+ * The return value is 1 if TclServiceIdle found something to do,
+ * otherwise return value is 0.
*
* Side effects:
* Invokes all pending idle handlers.
@@ -703,22 +711,20 @@ TclServiceIdle()
tsdPtr->idleGeneration++;
/*
- * The code below is trickier than it may look, for the following
- * reasons:
+ * The code below is trickier than it may look, for the following reasons:
*
- * 1. New handlers can get added to the list while the current
- * one is being processed. If new ones get added, we don't
- * want to process them during this pass through the list (want
- * to check for other work to do first). This is implemented
- * using the generation number in the handler: new handlers
- * will have a different generation than any of the ones currently
- * on the list.
- * 2. The handler can call Tcl_DoOneEvent, so we have to remove
- * the handler from the list before calling it. Otherwise an
- * infinite loop could result.
- * 3. Tcl_CancelIdleCall can be called to remove an element from
- * the list while a handler is executing, so the list could
- * change structure during the call.
+ * 1. New handlers can get added to the list while the current one is
+ * being processed. If new ones get added, we don't want to process
+ * them during this pass through the list (want to check for other work
+ * to do first). This is implemented using the generation number in the
+ * handler: new handlers will have a different generation than any of
+ * the ones currently on the list.
+ * 2. The handler can call Tcl_DoOneEvent, so we have to remove the
+ * handler from the list before calling it. Otherwise an infinite loop
+ * could result.
+ * 3. Tcl_CancelIdleCall can be called to remove an element from the list
+ * while a handler is executing, so the list could change structure
+ * during the call.
*/
for (idlePtr = tsdPtr->idleList;
@@ -745,8 +751,8 @@ TclServiceIdle()
*
* Tcl_AfterObjCmd --
*
- * This procedure is invoked to process the "after" Tcl command.
- * See the user documentation for details on what it does.
+ * This function is invoked to process the "after" Tcl command. See the
+ * user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
@@ -784,11 +790,11 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv)
}
/*
- * Create the "after" information associated for this interpreter,
- * if it doesn't already exist.
+ * Create the "after" information associated for this interpreter, if it
+ * doesn't already exist.
*/
- assocPtr = Tcl_GetAssocData( interp, "tclAfter", NULL );
+ assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL);
if (assocPtr == NULL) {
assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData));
assocPtr->interp = interp;
@@ -810,7 +816,7 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv)
if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) {
return TCL_ERROR;
}
-processInteger:
+ processInteger:
if (ms < 0) {
ms = 0;
}
@@ -825,15 +831,17 @@ processInteger:
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
+
/*
- * The variable below is used to generate unique identifiers for
- * after commands. This id can wrap around, which can potentially
- * cause problems. However, there are not likely to be problems
- * in practice, because after commands can only be requested to
- * about a month in the future, and wrap-around is unlikely to
- * occur in less than about 1-10 years. Thus it's unlikely that
- * any old ids will still be around when wrap-around occurs.
+ * The variable below is used to generate unique identifiers for after
+ * commands. This id can wrap around, which can potentially cause
+ * problems. However, there are not likely to be problems in practice,
+ * because after commands can only be requested to about a month in
+ * the future, and wrap-around is unlikely to occur in less than about
+ * 1-10 years. Thus it's unlikely that any old ids will still be
+ * around when wrap-around occurs.
*/
+
afterPtr->id = tsdPtr->afterId;
tsdPtr->afterId += 1;
afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc,
@@ -846,113 +854,113 @@ processInteger:
}
/*
- * If it's not a number it must be a subcommand.
+ * If it's not a number it must be a subcommand. Note that we're using a
+ * custom error message here, so we do not pass an interpreter to T_GIFO.
*/
- if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "argument",
- 0, &index) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "argument", 0,
+ &index) != TCL_OK) {
Tcl_AppendResult(interp, "bad argument \"", argString,
"\": must be cancel, idle, info, or a number",
(char *) NULL);
return TCL_ERROR;
}
switch ((enum afterSubCmds) index) {
- case AFTER_CANCEL: {
- Tcl_Obj *commandPtr;
- char *command, *tempCommand;
- int tempLength;
-
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "id|command");
- return TCL_ERROR;
+ case AFTER_CANCEL: {
+ Tcl_Obj *commandPtr;
+ char *command, *tempCommand;
+ int tempLength;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "id|command");
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ commandPtr = objv[2];
+ } else {
+ commandPtr = Tcl_ConcatObj(objc-2, objv+2);;
+ }
+ command = Tcl_GetStringFromObj(commandPtr, &length);
+ for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
+ afterPtr = afterPtr->nextPtr) {
+ tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr,
+ &tempLength);
+ if ((length == tempLength)
+ && (memcmp((void*) command, (void*) tempCommand,
+ (unsigned) length) == 0)) {
+ break;
}
- if (objc == 3) {
- commandPtr = objv[2];
+ }
+ if (afterPtr == NULL) {
+ afterPtr = GetAfterEvent(assocPtr, commandPtr);
+ }
+ if (objc != 3) {
+ Tcl_DecrRefCount(commandPtr);
+ }
+ if (afterPtr != NULL) {
+ if (afterPtr->token != NULL) {
+ Tcl_DeleteTimerHandler(afterPtr->token);
} else {
- commandPtr = Tcl_ConcatObj(objc-2, objv+2);;
+ Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
}
- command = Tcl_GetStringFromObj(commandPtr, &length);
- for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
+ FreeAfterPtr(afterPtr);
+ }
+ break;
+ }
+ case AFTER_IDLE:
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "script script ...");
+ return TCL_ERROR;
+ }
+ afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
+ afterPtr->assocPtr = assocPtr;
+ if (objc == 3) {
+ afterPtr->commandPtr = objv[2];
+ } else {
+ afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
+ }
+ Tcl_IncrRefCount(afterPtr->commandPtr);
+ afterPtr->id = tsdPtr->afterId;
+ tsdPtr->afterId += 1;
+ afterPtr->token = NULL;
+ afterPtr->nextPtr = assocPtr->firstAfterPtr;
+ assocPtr->firstAfterPtr = afterPtr;
+ Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);
+ sprintf(buf, "after#%d", afterPtr->id);
+ Tcl_AppendResult(interp, buf, (char *) NULL);
+ break;
+ case AFTER_INFO: {
+ Tcl_Obj *resultListPtr;
+
+ if (objc == 2) {
+ for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
- tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr,
- &tempLength);
- if ((length == tempLength)
- && (memcmp((void*) command, (void*) tempCommand,
- (unsigned) length) == 0)) {
- break;
+ if (assocPtr->interp == interp) {
+ sprintf(buf, "after#%d", afterPtr->id);
+ Tcl_AppendElement(interp, buf);
}
}
- if (afterPtr == NULL) {
- afterPtr = GetAfterEvent(assocPtr, commandPtr);
- }
- if (objc != 3) {
- Tcl_DecrRefCount(commandPtr);
- }
- if (afterPtr != NULL) {
- if (afterPtr->token != NULL) {
- Tcl_DeleteTimerHandler(afterPtr->token);
- } else {
- Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
- }
- FreeAfterPtr(afterPtr);
- }
- break;
+ return TCL_OK;
}
- case AFTER_IDLE:
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "script script ...");
- return TCL_ERROR;
- }
- afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
- afterPtr->assocPtr = assocPtr;
- if (objc == 3) {
- afterPtr->commandPtr = objv[2];
- } else {
- afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
- }
- Tcl_IncrRefCount(afterPtr->commandPtr);
- afterPtr->id = tsdPtr->afterId;
- tsdPtr->afterId += 1;
- afterPtr->token = NULL;
- afterPtr->nextPtr = assocPtr->firstAfterPtr;
- assocPtr->firstAfterPtr = afterPtr;
- Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);
- sprintf(buf, "after#%d", afterPtr->id);
- Tcl_AppendResult(interp, buf, (char *) NULL);
- break;
- case AFTER_INFO: {
- Tcl_Obj *resultListPtr;
-
- if (objc == 2) {
- for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
- afterPtr = afterPtr->nextPtr) {
- if (assocPtr->interp == interp) {
- sprintf(buf, "after#%d", afterPtr->id);
- Tcl_AppendElement(interp, buf);
- }
- }
- return TCL_OK;
- }
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "?id?");
- return TCL_ERROR;
- }
- afterPtr = GetAfterEvent(assocPtr, objv[2]);
- if (afterPtr == NULL) {
- Tcl_AppendResult(interp, "event \"", Tcl_GetString(objv[2]),
- "\" doesn't exist", (char *) NULL);
- return TCL_ERROR;
- }
- resultListPtr = Tcl_NewObj();
- Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr);
- Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
- (afterPtr->token == NULL) ? "idle" : "timer", -1));
- Tcl_SetObjResult(interp, resultListPtr);
- break;
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?id?");
+ return TCL_ERROR;
}
- default: {
- Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
+ afterPtr = GetAfterEvent(assocPtr, objv[2]);
+ if (afterPtr == NULL) {
+ Tcl_AppendResult(interp, "event \"", Tcl_GetString(objv[2]),
+ "\" doesn't exist", (char *) NULL);
+ return TCL_ERROR;
}
+ resultListPtr = Tcl_NewObj();
+ Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr);
+ Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
+ (afterPtr->token == NULL) ? "idle" : "timer", -1));
+ Tcl_SetObjResult(interp, resultListPtr);
+ break;
+ }
+ default:
+ Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
}
return TCL_OK;
}
@@ -962,13 +970,12 @@ processInteger:
*
* AfterDelay --
*
- * Implements the blocking delay behaviour of [after $time].
- * Tricky because it has to take into account any time limit that
- * has been set.
+ * Implements the blocking delay behaviour of [after $time]. Tricky
+ * because it has to take into account any time limit that has been set.
*
* Results:
- * Standard Tcl result code (with error set if an error occurred
- * due to a time limit being exceeded).
+ * Standard Tcl result code (with error set if an error occurred due to a
+ * time limit being exceeded).
*
* Side effects:
* May adjust the time limit granularity marker.
@@ -982,11 +989,6 @@ AfterDelay(interp, ms)
int ms;
{
Interp *iPtr = (Interp *) interp;
-#define TCL_TIME_BEFORE(t1,t2) \
- (((t1).sec<(t2).sec)||((t1).sec==(t2).sec&&(t1).usec<(t2).usec))
-#define TCL_TIME_DIFF_MS(t1,t2) \
- (1000*((long)(t1).sec - (long)(t2).sec) + \
- ((long)(t1).usec - (long)(t2).usec)/1000)
if (iPtr->limit.timeEvent != NULL) {
Tcl_Time endTime, now;
@@ -1020,8 +1022,6 @@ AfterDelay(interp, ms)
} else {
Tcl_Sleep(ms);
}
-#undef TCL_TIME_BEFORE
-#undef TCL_TIME_DIFF_MS
return TCL_OK;
}
@@ -1030,13 +1030,13 @@ AfterDelay(interp, ms)
*
* GetAfterEvent --
*
- * This procedure parses an "after" id such as "after#4" and
- * returns a pointer to the AfterInfo structure.
+ * This function parses an "after" id such as "after#4" and returns a
+ * pointer to the AfterInfo structure.
*
* Results:
- * The return value is either a pointer to an AfterInfo structure,
- * if one is found that corresponds to "cmdString" and is for interp,
- * or NULL if no corresponding after event can be found.
+ * The return value is either a pointer to an AfterInfo structure, if one
+ * is found that corresponds to "cmdString" and is for interp, or NULL if
+ * no corresponding after event can be found.
*
* Side effects:
* None.
@@ -1050,8 +1050,8 @@ GetAfterEvent(assocPtr, commandPtr)
* this interpreter. */
Tcl_Obj *commandPtr;
{
- char *cmdString; /* Textual identifier for after event, such
- * as "after#6". */
+ char *cmdString; /* Textual identifier for after event, such as
+ * "after#6". */
AfterInfo *afterPtr;
int id;
char *end;
@@ -1079,17 +1079,16 @@ GetAfterEvent(assocPtr, commandPtr)
*
* AfterProc --
*
- * Timer callback to execute commands registered with the
- * "after" command.
+ * Timer callback to execute commands registered with the "after"
+ * command.
*
* Results:
* None.
*
* Side effects:
- * Executes whatever command was specified. If the command
- * returns an error, then the command "bgerror" is invoked
- * to process the error; if bgerror fails then information
- * about the error is output on stderr.
+ * Executes whatever command was specified. If the command returns an
+ * error, then the command "bgerror" is invoked to process the error; if
+ * bgerror fails then information about the error is output on stderr.
*
*----------------------------------------------------------------------
*/
@@ -1107,9 +1106,9 @@ AfterProc(clientData)
int numBytes;
/*
- * First remove the callback from our list of callbacks; otherwise
- * someone could delete the callback while it's being executed, which
- * could cause a core dump.
+ * First remove the callback from our list of callbacks; otherwise someone
+ * could delete the callback while it's being executed, which could cause
+ * a core dump.
*/
if (assocPtr->firstAfterPtr == afterPtr) {
@@ -1135,7 +1134,7 @@ AfterProc(clientData)
Tcl_BackgroundError(interp);
}
Tcl_Release((ClientData) interp);
-
+
/*
* Free the memory for the callback.
*/
@@ -1149,10 +1148,9 @@ AfterProc(clientData)
*
* FreeAfterPtr --
*
- * This procedure removes an "after" command from the list of
- * those that are pending and frees its resources. This procedure
- * does *not* cancel the timer handler; if that's needed, the
- * caller must do it.
+ * This function removes an "after" command from the list of those that
+ * are pending and frees its resources. This function does *not* cancel
+ * the timer handler; if that's needed, the caller must do it.
*
* Results:
* None.
@@ -1188,7 +1186,7 @@ FreeAfterPtr(afterPtr)
*
* AfterCleanupProc --
*
- * This procedure is invoked whenever an interpreter is deleted
+ * This function is invoked whenever an interpreter is deleted
* to cleanup the AssocData for "tclAfter".
*
* Results:
@@ -1223,3 +1221,11 @@ AfterCleanupProc(clientData, interp)
}
ckfree((char *) assocPtr);
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 248a38d..1031334 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -1,17 +1,17 @@
-/*
+/*
* tclUtil.c --
*
- * This file contains utility procedures that are used by many Tcl
+ * This file contains utility functions that are used by many Tcl
* commands.
*
* Copyright (c) 1987-1993 The Regents of the University of California.
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclUtil.c,v 1.61 2005/07/05 18:15:59 dgp Exp $
+ * RCS: @(#) $Id: tclUtil.c,v 1.62 2005/07/24 22:56:44 dkf Exp $
*/
#include "tclInt.h"
@@ -45,27 +45,27 @@
static ProcessGlobalValue executableName = {0, 0, NULL, NULL, NULL, NULL, NULL};
/*
- * The following values are used in the flags returned by Tcl_ScanElement
- * and used by Tcl_ConvertElement. The values TCL_DONT_USE_BRACES and
- * TCL_DONT_QUOTE_HASH are defined in tcl.h; make sure neither value
- * overlaps with any of the values below.
+ * The following values are used in the flags returned by Tcl_ScanElement and
+ * used by Tcl_ConvertElement. The values TCL_DONT_USE_BRACES and
+ * TCL_DONT_QUOTE_HASH are defined in tcl.h; make sure neither value overlaps
+ * with any of the values below.
*
* TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in
- * braces (e.g. it contains unmatched braces,
- * or ends in a backslash character, or user
- * just doesn't want braces); handle all
- * special characters by adding backslashes.
+ * braces (e.g. it contains unmatched braces, or
+ * ends in a backslash character, or user just
+ * doesn't want braces); handle all special
+ * characters by adding backslashes.
* USE_BRACES - 1 means the string contains a special
* character that can be handled simply by
* enclosing the entire argument in braces.
- * BRACES_UNMATCHED - 1 means that braces aren't properly matched
- * in the argument.
- * TCL_DONT_QUOTE_HASH - 1 means the caller insists that a leading
- * hash character ('#') should *not* be quoted.
- * This is appropriate when the caller can
- * guarantee the element is not the first element
- * of a list, so [eval] cannot mis-parse the
- * element as a comment.
+ * BRACES_UNMATCHED - 1 means that braces aren't properly matched in
+ * the argument.
+ * TCL_DONT_QUOTE_HASH - 1 means the caller insists that a leading hash
+ * character ('#') should *not* be quoted. This
+ * is appropriate when the caller can guarantee
+ * the element is not the first element of a
+ * list, so [eval] cannot mis-parse the element
+ * as a comment.
*/
#define USE_BRACES 2
@@ -73,43 +73,42 @@ static ProcessGlobalValue executableName = {0, 0, NULL, NULL, NULL, NULL, NULL};
/*
* The following values determine the precision used when converting
- * floating-point values to strings. This information is linked to all
- * of the tcl_precision variables in all interpreters via the procedure
+ * floating-point values to strings. This information is linked to all of the
+ * tcl_precision variables in all interpreters via the function
* TclPrecTraceProc.
*/
-static int precision = 0; /* Precision of floating point conversions,
- * in the range 0-17 inclusive. */
+static int precision = 0; /* Precision of floating point conversions, in
+ * the range 0-17 inclusive. */
TCL_DECLARE_MUTEX(precisionMutex)
/*
- * Prototypes for procedures defined later in this file.
+ * Prototypes for functions defined later in this file.
*/
static void ClearHash _ANSI_ARGS_((Tcl_HashTable *tablePtr));
static void FreeProcessGlobalValue _ANSI_ARGS_((
ClientData clientData));
-static void FreeThreadHash _ANSI_ARGS_ ((ClientData clientData));
-static Tcl_HashTable * GetThreadHash _ANSI_ARGS_ ((Tcl_ThreadDataKey *keyPtr));
+static void FreeThreadHash _ANSI_ARGS_((ClientData clientData));
+static Tcl_HashTable * GetThreadHash _ANSI_ARGS_((Tcl_ThreadDataKey *keyPtr));
static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp,
- Tcl_Obj* objPtr));
+ Tcl_Obj* objPtr));
static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr));
/*
- * The following is the Tcl object type definition for an object
- * that represents a list index in the form, "end-offset". It is
- * used as a performance optimization in TclGetIntForIndex. The
- * internal rep is an integer, so no memory management is required
- * for it.
+ * The following is the Tcl object type definition for an object that
+ * represents a list index in the form, "end-offset". It is used as a
+ * performance optimization in TclGetIntForIndex. The internal rep is an
+ * integer, so no memory management is required for it.
*/
Tcl_ObjType tclEndOffsetType = {
"end-offset", /* name */
(Tcl_FreeInternalRepProc*) NULL, /* freeIntRepProc */
- (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */
+ (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */
UpdateStringOfEndOffset, /* updateStringProc */
- SetEndOffsetFromAny
+ SetEndOffsetFromAny
};
@@ -118,28 +117,28 @@ Tcl_ObjType tclEndOffsetType = {
*
* TclFindElement --
*
- * Given a pointer into a Tcl list, locate the first (or next)
- * element in the list.
+ * Given a pointer into a Tcl list, locate the first (or next) element in
+ * the list.
*
* Results:
- * The return value is normally TCL_OK, which means that the
- * element was successfully located. If TCL_ERROR is returned
- * it means that list didn't have proper list structure;
- * the interp's result contains a more detailed error message.
+ * The return value is normally TCL_OK, which means that the element was
+ * successfully located. If TCL_ERROR is returned it means that list
+ * didn't have proper list structure; the interp's result contains a more
+ * detailed error message.
*
* If TCL_OK is returned, then *elementPtr will be set to point to the
* first element of list, and *nextPtr will be set to point to the
* character just after any white space following the last character
- * that's part of the element. If this is the last argument in the
- * list, then *nextPtr will point just after the last character in the
- * list (i.e., at the character at list+listLength). If sizePtr is
- * non-NULL, *sizePtr is filled in with the number of characters in the
- * element. If the element is in braces, then *elementPtr will point
- * to the character after the opening brace and *sizePtr will not
- * include either of the braces. If there isn't an element in the list,
- * *sizePtr will be zero, and both *elementPtr and *termPtr will point
- * just after the last character in the list. Note: this procedure does
- * NOT collapse backslash sequences.
+ * that's part of the element. If this is the last argument in the list,
+ * then *nextPtr will point just after the last character in the list
+ * (i.e., at the character at list+listLength). If sizePtr is non-NULL,
+ * *sizePtr is filled in with the number of characters in the element. If
+ * the element is in braces, then *elementPtr will point to the character
+ * after the opening brace and *sizePtr will not include either of the
+ * braces. If there isn't an element in the list, *sizePtr will be zero,
+ * and both *elementPtr and *termPtr will point just after the last
+ * character in the list. Note: this function does NOT collapse backslash
+ * sequences.
*
* Side effects:
* None.
@@ -149,10 +148,10 @@ Tcl_ObjType tclEndOffsetType = {
int
TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
- bracePtr)
- Tcl_Interp *interp; /* Interpreter to use for error reporting.
- * If NULL, then no error message is left
- * after errors. */
+ bracePtr)
+ Tcl_Interp *interp; /* Interpreter to use for error reporting. If
+ * NULL, then no error message is left after
+ * errors. */
CONST char *list; /* Points to the first byte of a string
* containing a Tcl list with zero or more
* elements (possibly in braces). */
@@ -164,9 +163,8 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
* argument (next arg or end of list). */
int *sizePtr; /* If non-zero, fill in with size of
* element. */
- int *bracePtr; /* If non-zero, fill in with non-zero/zero
- * to indicate that arg was/wasn't
- * in braces. */
+ int *bracePtr; /* If non-zero, fill in with non-zero/zero to
+ * indicate that arg was/wasn't in braces. */
{
CONST char *p = list;
CONST char *elemStart; /* Points to first byte of first element. */
@@ -176,11 +174,11 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
int size = 0; /* lint. */
int numChars;
CONST char *p2;
-
+
/*
- * Skim off leading white space and check for an opening brace or
- * quote. We treat embedded NULLs in the list as bytes belonging to
- * a list element.
+ * Skim off leading white space and check for an opening brace or quote.
+ * We treat embedded NULLs in the list as bytes belonging to a list
+ * element.
*/
limit = (list + listLength);
@@ -210,123 +208,120 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
while (p < limit) {
switch (*p) {
-
/*
* Open brace: don't treat specially unless the element is in
* braces. In this case, keep a nesting count.
*/
- case '{':
- if (openBraces != 0) {
- openBraces++;
- }
- break;
+ case '{':
+ if (openBraces != 0) {
+ openBraces++;
+ }
+ break;
/*
* Close brace: if element is in braces, keep nesting count and
* quit when the last close brace is seen.
*/
- case '}':
- if (openBraces > 1) {
- openBraces--;
- } else if (openBraces == 1) {
- size = (p - elemStart);
- p++;
- if ((p >= limit)
- || isspace(UCHAR(*p))) { /* INTL: ISO space. */
- goto done;
- }
+ case '}':
+ if (openBraces > 1) {
+ openBraces--;
+ } else if (openBraces == 1) {
+ size = (p - elemStart);
+ p++;
+ if ((p >= limit)
+ || isspace(UCHAR(*p))) { /* INTL: ISO space. */
+ goto done;
+ }
- /*
- * Garbage after the closing brace; return an error.
- */
-
- if (interp != NULL) {
- char buf[100];
-
- p2 = p;
- while ((p2 < limit)
- && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */
- && (p2 < p+20)) {
- p2++;
- }
- sprintf(buf,
- "list element in braces followed by \"%.*s\" instead of space",
- (int) (p2-p), p);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ /*
+ * Garbage after the closing brace; return an error.
+ */
+
+ if (interp != NULL) {
+ char buf[100];
+
+ p2 = p;
+ while ((p2 < limit)
+ && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */
+ && (p2 < p+20)) {
+ p2++;
}
- return TCL_ERROR;
+ sprintf(buf,
+ "list element in braces followed by \"%.*s\" instead of space",
+ (int) (p2-p), p);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
}
- break;
+ return TCL_ERROR;
+ }
+ break;
/*
- * Backslash: skip over everything up to the end of the
- * backslash sequence.
+ * Backslash: skip over everything up to the end of the backslash
+ * sequence.
*/
- case '\\': {
- Tcl_UtfBackslash(p, &numChars, NULL);
- p += (numChars - 1);
- break;
- }
+ case '\\':
+ Tcl_UtfBackslash(p, &numChars, NULL);
+ p += (numChars - 1);
+ break;
/*
* Space: ignore if element is in braces or quotes; otherwise
* terminate element.
*/
- case ' ':
- case '\f':
- case '\n':
- case '\r':
- case '\t':
- case '\v':
- if ((openBraces == 0) && !inQuotes) {
- size = (p - elemStart);
- goto done;
- }
- break;
+ case ' ':
+ case '\f':
+ case '\n':
+ case '\r':
+ case '\t':
+ case '\v':
+ if ((openBraces == 0) && !inQuotes) {
+ size = (p - elemStart);
+ goto done;
+ }
+ break;
/*
* Double-quote: if element is in quotes then terminate it.
*/
- case '"':
- if (inQuotes) {
- size = (p - elemStart);
- p++;
- if ((p >= limit)
- || isspace(UCHAR(*p))) { /* INTL: ISO space */
- goto done;
- }
+ case '"':
+ if (inQuotes) {
+ size = (p - elemStart);
+ p++;
+ if ((p >= limit)
+ || isspace(UCHAR(*p))) { /* INTL: ISO space */
+ goto done;
+ }
- /*
- * Garbage after the closing quote; return an error.
- */
-
- if (interp != NULL) {
- char buf[100];
-
- p2 = p;
- while ((p2 < limit)
- && (!isspace(UCHAR(*p2))) /* INTL: ISO space */
- && (p2 < p+20)) {
- p2++;
- }
- sprintf(buf,
- "list element in quotes followed by \"%.*s\" %s",
- (int) (p2-p), p, "instead of space");
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ /*
+ * Garbage after the closing quote; return an error.
+ */
+
+ if (interp != NULL) {
+ char buf[100];
+
+ p2 = p;
+ while ((p2 < limit)
+ && (!isspace(UCHAR(*p2))) /* INTL: ISO space */
+ && (p2 < p+20)) {
+ p2++;
}
- return TCL_ERROR;
+ sprintf(buf,
+ "list element in quotes followed by \"%.*s\" %s",
+ (int) (p2-p), p, "instead of space");
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
}
- break;
+ return TCL_ERROR;
+ }
+ break;
}
p++;
}
-
/*
* End of list: terminate element.
*/
@@ -348,7 +343,7 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
size = (p - elemStart);
}
- done:
+ done:
while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */
p++;
}
@@ -368,11 +363,11 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
* Copy a string and eliminate any backslashes that aren't in braces.
*
* Results:
- * Count characters get copied from src to dst. Along the way, if
+ * Count characters get copied from src to dst. Along the way, if
* backslash sequences are found outside braces, the backslashes are
- * eliminated in the copy. After scanning count chars from source, a
- * null character is placed at the end of dst. Returns the number
- * of characters that got copied.
+ * eliminated in the copy. After scanning count chars from source, a null
+ * character is placed at the end of dst. Returns the number of
+ * characters that got copied.
*
* Side effects:
* None.
@@ -416,21 +411,19 @@ TclCopyAndCollapse(count, src, dst)
* Splits a list up into its constituent fields.
*
* Results
- * The return value is normally TCL_OK, which means that
- * the list was successfully split up. If TCL_ERROR is
- * returned, it means that "list" didn't have proper list
- * structure; the interp's result will contain a more detailed
- * error message.
- *
- * *argvPtr will be filled in with the address of an array
- * whose elements point to the elements of list, in order.
- * *argcPtr will get filled in with the number of valid elements
- * in the array. A single block of memory is dynamically allocated
- * to hold both the argv array and a copy of the list (with
- * backslashes and braces removed in the standard way).
- * The caller must eventually free this memory by calling free()
- * on *argvPtr. Note: *argvPtr and *argcPtr are only modified
- * if the procedure returns normally.
+ * The return value is normally TCL_OK, which means that the list was
+ * successfully split up. If TCL_ERROR is returned, it means that "list"
+ * didn't have proper list structure; the interp's result will contain a
+ * more detailed error message.
+ *
+ * *argvPtr will be filled in with the address of an array whose elements
+ * point to the elements of list, in order. *argcPtr will get filled in
+ * with the number of valid elements in the array. A single block of
+ * memory is dynamically allocated to hold both the argv array and a copy
+ * of the list (with backslashes and braces removed in the standard way).
+ * The caller must eventually free this memory by calling free() on
+ * *argvPtr. Note: *argvPtr and *argcPtr are only modified if the
+ * function returns normally.
*
* Side effects:
* Memory is allocated.
@@ -440,13 +433,13 @@ TclCopyAndCollapse(count, src, dst)
int
Tcl_SplitList(interp, list, argcPtr, argvPtr)
- Tcl_Interp *interp; /* Interpreter to use for error reporting.
- * If NULL, no error message is left. */
+ Tcl_Interp *interp; /* Interpreter to use for error reporting. If
+ * NULL, no error message is left. */
CONST char *list; /* Pointer to string with list structure. */
- int *argcPtr; /* Pointer to location to fill in with
- * the number of elements in the list. */
- CONST char ***argvPtr; /* Pointer to place to store pointer to
- * array of pointers to list elements. */
+ int *argcPtr; /* Pointer to location to fill in with the
+ * number of elements in the list. */
+ CONST char ***argvPtr; /* Pointer to place to store pointer to array
+ * of pointers to list elements. */
{
CONST char **argv;
CONST char *l;
@@ -455,10 +448,10 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr)
CONST char *element;
/*
- * Figure out how much space to allocate. There must be enough
- * space for both the array of pointers and also for a copy of
- * the list. To estimate the number of pointers needed, count
- * the number of space characters in the list.
+ * Figure out how much space to allocate. There must be enough space for
+ * both the array of pointers and also for a copy of the list. To estimate
+ * the number of pointers needed, count the number of space characters in
+ * the list.
*/
for (size = 1, l = list; *l != 0; l++) {
@@ -473,7 +466,7 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr)
for (i = 0, p = ((char *) argv) + size*sizeof(char *);
*list != 0; i++) {
CONST char *prevList = list;
-
+
result = TclFindElement(interp, list, length, &element,
&list, &elSize, &brace);
length -= (list - prevList);
@@ -515,17 +508,15 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr)
*
* Tcl_ScanElement --
*
- * This procedure is a companion procedure to Tcl_ConvertElement.
- * It scans a string to see what needs to be done to it (e.g. add
- * backslashes or enclosing braces) to make the string into a
- * valid Tcl list element.
+ * This function is a companion function to Tcl_ConvertElement. It scans
+ * a string to see what needs to be done to it (e.g. add backslashes or
+ * enclosing braces) to make the string into a valid Tcl list element.
*
* Results:
- * The return value is an overestimate of the number of characters
- * that will be needed by Tcl_ConvertElement to produce a valid
- * list element from string. The word at *flagPtr is filled in
- * with a value needed by Tcl_ConvertElement when doing the actual
- * conversion.
+ * The return value is an overestimate of the number of characters that
+ * will be needed by Tcl_ConvertElement to produce a valid list element
+ * from string. The word at *flagPtr is filled in with a value needed by
+ * Tcl_ConvertElement when doing the actual conversion.
*
* Side effects:
* None.
@@ -547,19 +538,17 @@ Tcl_ScanElement(string, flagPtr)
*
* Tcl_ScanCountedElement --
*
- * This procedure is a companion procedure to
- * Tcl_ConvertCountedElement. It scans a string to see what
- * needs to be done to it (e.g. add backslashes or enclosing
- * braces) to make the string into a valid Tcl list element.
- * If length is -1, then the string is scanned up to the first
- * null byte.
+ * This function is a companion function to Tcl_ConvertCountedElement. It
+ * scans a string to see what needs to be done to it (e.g. add
+ * backslashes or enclosing braces) to make the string into a valid Tcl
+ * list element. If length is -1, then the string is scanned up to the
+ * first null byte.
*
* Results:
- * The return value is an overestimate of the number of characters
- * that will be needed by Tcl_ConvertCountedElement to produce a
- * valid list element from string. The word at *flagPtr is
- * filled in with a value needed by Tcl_ConvertCountedElement
- * when doing the actual conversion.
+ * The return value is an overestimate of the number of characters that
+ * will be needed by Tcl_ConvertCountedElement to produce a valid list
+ * element from string. The word at *flagPtr is filled in with a value
+ * needed by Tcl_ConvertCountedElement when doing the actual conversion.
*
* Side effects:
* None.
@@ -578,44 +567,44 @@ Tcl_ScanCountedElement(string, length, flagPtr)
register CONST char *p, *lastChar;
/*
- * This procedure and Tcl_ConvertElement together do two things:
+ * This function and Tcl_ConvertElement together do two things:
+ *
+ * 1. They produce a proper list, one that will yield back the argument
+ * strings when evaluated or when disassembled with Tcl_SplitList. This
+ * is the most important thing.
*
- * 1. They produce a proper list, one that will yield back the
- * argument strings when evaluated or when disassembled with
- * Tcl_SplitList. This is the most important thing.
- *
- * 2. They try to produce legible output, which means minimizing the
- * use of backslashes (using braces instead). However, there are
- * some situations where backslashes must be used (e.g. an element
- * like "{abc": the leading brace will have to be backslashed.
- * For each element, one of three things must be done:
+ * 2. They try to produce legible output, which means minimizing the use
+ * of backslashes (using braces instead). However, there are some
+ * situations where backslashes must be used (e.g. an element like
+ * "{abc": the leading brace will have to be backslashed. For each
+ * element, one of three things must be done:
*
- * (a) Use the element as-is (it doesn't contain any special
- * characters). This is the most desirable option.
+ * (a) Use the element as-is (it doesn't contain any special
+ * characters). This is the most desirable option.
*
- * (b) Enclose the element in braces, but leave the contents alone.
- * This happens if the element contains embedded space, or if it
- * contains characters with special interpretation ($, [, ;, or \),
- * or if it starts with a brace or double-quote, or if there are
- * no characters in the element.
+ * (b) Enclose the element in braces, but leave the contents alone.
+ * This happens if the element contains embedded space, or if it
+ * contains characters with special interpretation ($, [, ;, or \),
+ * or if it starts with a brace or double-quote, or if there are no
+ * characters in the element.
*
- * (c) Don't enclose the element in braces, but add backslashes to
- * prevent special interpretation of special characters. This is a
- * last resort used when the argument would normally fall under case
- * (b) but contains unmatched braces. It also occurs if the last
- * character of the argument is a backslash or if the element contains
- * a backslash followed by newline.
+ * (c) Don't enclose the element in braces, but add backslashes to
+ * prevent special interpretation of special characters. This is a
+ * last resort used when the argument would normally fall under
+ * case (b) but contains unmatched braces. It also occurs if the
+ * last character of the argument is a backslash or if the element
+ * contains a backslash followed by newline.
*
- * The procedure figures out how many bytes will be needed to store
- * the result (actually, it overestimates). It also collects information
- * about the element in the form of a flags word.
+ * The function figures out how many bytes will be needed to store the
+ * result (actually, it overestimates). It also collects information about
+ * the element in the form of a flags word.
*
- * Note: list elements produced by this procedure and
+ * Note: list elements produced by this function and
* Tcl_ConvertCountedElement must have the property that they can be
- * enclosing in curly braces to make sub-lists. This means, for
- * example, that we must not leave unmatched curly braces in the
- * resulting list element. This property is necessary in order for
- * procedures like Tcl_DStringStartSublist to work.
+ * enclosing in curly braces to make sub-lists. This means, for example,
+ * that we must not leave unmatched curly braces in the resulting list
+ * element. This property is necessary in order for functions like
+ * Tcl_DStringStartSublist to work.
*/
nestingLevel = 0;
@@ -631,39 +620,39 @@ Tcl_ScanCountedElement(string, length, flagPtr)
if ((p == lastChar) || (*p == '{') || (*p == '"')) {
flags |= USE_BRACES;
}
- for ( ; p < lastChar; p++) {
+ for (; p < lastChar; p++) {
switch (*p) {
- case '{':
- nestingLevel++;
- break;
- case '}':
- nestingLevel--;
- if (nestingLevel < 0) {
- flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED;
- }
- break;
- case '[':
- case '$':
- case ';':
- case ' ':
- case '\f':
- case '\n':
- case '\r':
- case '\t':
- case '\v':
- flags |= USE_BRACES;
- break;
- case '\\':
- if ((p+1 == lastChar) || (p[1] == '\n')) {
- flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
- } else {
- int size;
+ case '{':
+ nestingLevel++;
+ break;
+ case '}':
+ nestingLevel--;
+ if (nestingLevel < 0) {
+ flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED;
+ }
+ break;
+ case '[':
+ case '$':
+ case ';':
+ case ' ':
+ case '\f':
+ case '\n':
+ case '\r':
+ case '\t':
+ case '\v':
+ flags |= USE_BRACES;
+ break;
+ case '\\':
+ if ((p+1 == lastChar) || (p[1] == '\n')) {
+ flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
+ } else {
+ int size;
- Tcl_UtfBackslash(p, &size, NULL);
- p += size-1;
- flags |= USE_BRACES;
- }
- break;
+ Tcl_UtfBackslash(p, &size, NULL);
+ p += size-1;
+ flags |= USE_BRACES;
+ }
+ break;
}
}
if (nestingLevel != 0) {
@@ -672,8 +661,8 @@ Tcl_ScanCountedElement(string, length, flagPtr)
*flagPtr = flags;
/*
- * Allow enough space to backslash every character plus leave
- * two spaces for braces.
+ * Allow enough space to backslash every character plus leave two spaces
+ * for braces.
*/
return 2*(p-string) + 2;
@@ -684,16 +673,15 @@ Tcl_ScanCountedElement(string, length, flagPtr)
*
* Tcl_ConvertElement --
*
- * This is a companion procedure to Tcl_ScanElement. Given
- * the information produced by Tcl_ScanElement, this procedure
- * converts a string to a list element equal to that string.
+ * This is a companion function to Tcl_ScanElement. Given the information
+ * produced by Tcl_ScanElement, this function converts a string to a list
+ * element equal to that string.
*
* Results:
- * Information is copied to *dst in the form of a list element
- * identical to src (i.e. if Tcl_SplitList is applied to dst it
- * will produce a string identical to src). The return value is
- * a count of the number of characters copied (not including the
- * terminating NULL character).
+ * Information is copied to *dst in the form of a list element identical
+ * to src (i.e. if Tcl_SplitList is applied to dst it will produce a
+ * string identical to src). The return value is a count of the number of
+ * characters copied (not including the terminating NULL character).
*
* Side effects:
* None.
@@ -715,17 +703,15 @@ Tcl_ConvertElement(src, dst, flags)
*
* Tcl_ConvertCountedElement --
*
- * This is a companion procedure to Tcl_ScanCountedElement. Given
- * the information produced by Tcl_ScanCountedElement, this
- * procedure converts a string to a list element equal to that
- * string.
+ * This is a companion function to Tcl_ScanCountedElement. Given the
+ * information produced by Tcl_ScanCountedElement, this function converts
+ * a string to a list element equal to that string.
*
* Results:
- * Information is copied to *dst in the form of a list element
- * identical to src (i.e. if Tcl_SplitList is applied to dst it
- * will produce a string identical to src). The return value is
- * a count of the number of characters copied (not including the
- * terminating NULL character).
+ * Information is copied to *dst in the form of a list element identical
+ * to src (i.e. if Tcl_SplitList is applied to dst it will produce a
+ * string identical to src). The return value is a count of the number of
+ * characters copied (not including the terminating NULL character).
*
* Side effects:
* None.
@@ -744,8 +730,8 @@ Tcl_ConvertCountedElement(src, length, dst, flags)
register CONST char *lastChar;
/*
- * See the comment block at the beginning of the Tcl_ScanElement
- * code for details of how this works.
+ * See the comment block at the beginning of the Tcl_ScanElement code for
+ * details of how this works.
*/
if (src && length == -1) {
@@ -764,7 +750,7 @@ Tcl_ConvertCountedElement(src, length, dst, flags)
if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) {
*p = '{';
p++;
- for ( ; src != lastChar; src++, p++) {
+ for (; src != lastChar; src++, p++) {
*p = *src;
}
*p = '}';
@@ -772,10 +758,10 @@ Tcl_ConvertCountedElement(src, length, dst, flags)
} else {
if (*src == '{') {
/*
- * Can't have a leading brace unless the whole element is
- * enclosed in braces. Add a backslash before the brace.
- * Furthermore, this may destroy the balance between open
- * and close braces, so set BRACES_UNMATCHED.
+ * Can't have a leading brace unless the whole element is enclosed
+ * in braces. Add a backslash before the brace. Furthermore, this
+ * may destroy the balance between open and close braces, so set
+ * BRACES_UNMATCHED.
*/
p[0] = '\\';
@@ -785,9 +771,8 @@ Tcl_ConvertCountedElement(src, length, dst, flags)
flags |= BRACES_UNMATCHED;
} else if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) {
/*
- * Leading '#' could be seen by [eval] as the start of
- * a comment, if on the first element of a list, so
- * quote it.
+ * Leading '#' could be seen by [eval] as the start of a comment,
+ * if on the first element of a list, so quote it.
*/
p[0] = '\\';
@@ -797,62 +782,62 @@ Tcl_ConvertCountedElement(src, length, dst, flags)
}
for (; src != lastChar; src++) {
switch (*src) {
- case ']':
- case '[':
- case '$':
- case ';':
- case ' ':
- case '\\':
- case '"':
- *p = '\\';
- p++;
- break;
- case '{':
- case '}':
- /*
- * It may not seem necessary to backslash braces, but
- * it is. The reason for this is that the resulting
- * list element may actually be an element of a sub-list
- * enclosed in braces (e.g. if Tcl_DStringStartSublist
- * has been invoked), so there may be a brace mismatch
- * if the braces aren't backslashed.
- */
-
- if (flags & BRACES_UNMATCHED) {
- *p = '\\';
- p++;
- }
- break;
- case '\f':
- *p = '\\';
- p++;
- *p = 'f';
- p++;
- continue;
- case '\n':
- *p = '\\';
- p++;
- *p = 'n';
- p++;
- continue;
- case '\r':
- *p = '\\';
- p++;
- *p = 'r';
- p++;
- continue;
- case '\t':
- *p = '\\';
- p++;
- *p = 't';
- p++;
- continue;
- case '\v':
+ case ']':
+ case '[':
+ case '$':
+ case ';':
+ case ' ':
+ case '\\':
+ case '"':
+ *p = '\\';
+ p++;
+ break;
+ case '{':
+ case '}':
+ /*
+ * It may not seem necessary to backslash braces, but it is.
+ * The reason for this is that the resulting list element may
+ * actually be an element of a sub-list enclosed in braces
+ * (e.g. if Tcl_DStringStartSublist has been invoked), so
+ * there may be a brace mismatch if the braces aren't
+ * backslashed.
+ */
+
+ if (flags & BRACES_UNMATCHED) {
*p = '\\';
p++;
- *p = 'v';
- p++;
- continue;
+ }
+ break;
+ case '\f':
+ *p = '\\';
+ p++;
+ *p = 'f';
+ p++;
+ continue;
+ case '\n':
+ *p = '\\';
+ p++;
+ *p = 'n';
+ p++;
+ continue;
+ case '\r':
+ *p = '\\';
+ p++;
+ *p = 'r';
+ p++;
+ continue;
+ case '\t':
+ *p = '\\';
+ p++;
+ *p = 't';
+ p++;
+ continue;
+ case '\v':
+ *p = '\\';
+ p++;
+ *p = 'v';
+ p++;
+ continue;
}
*p = *src;
p++;
@@ -867,15 +852,14 @@ Tcl_ConvertCountedElement(src, length, dst, flags)
*
* Tcl_Merge --
*
- * Given a collection of strings, merge them together into a
- * single string that has proper Tcl list structured (i.e.
- * Tcl_SplitList may be used to retrieve strings equal to the
- * original elements, and Tcl_Eval will parse the string back
- * into its original elements).
+ * Given a collection of strings, merge them together into a single
+ * string that has proper Tcl list structured (i.e. Tcl_SplitList may be
+ * used to retrieve strings equal to the original elements, and Tcl_Eval
+ * will parse the string back into its original elements).
*
* Results:
- * The return value is the address of a dynamically-allocated
- * string containing the merged list.
+ * The return value is the address of a dynamically-allocated string
+ * containing the merged list.
*
* Side effects:
* None.
@@ -916,7 +900,7 @@ Tcl_Merge(argc, argv)
result = (char *) ckalloc((unsigned) numChars);
dst = result;
for (i = 0; i < argc; i++) {
- numChars = Tcl_ConvertElement(argv[i], dst,
+ numChars = Tcl_ConvertElement(argv[i], dst,
flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH) );
dst += numChars;
*dst = ' ';
@@ -942,10 +926,10 @@ Tcl_Merge(argc, argv)
* Figure out how to handle a backslash sequence.
*
* Results:
- * The return value is the character that should be substituted
- * in place of the backslash sequence that starts at src. If
- * readPtr isn't NULL then it is filled in with a count of the
- * number of characters in the backslash sequence.
+ * The return value is the character that should be substituted in place
+ * of the backslash sequence that starts at src. If readPtr isn't NULL
+ * then it is filled in with a count of the number of characters in the
+ * backslash sequence.
*
* Side effects:
* None.
@@ -955,10 +939,10 @@ Tcl_Merge(argc, argv)
char
Tcl_Backslash(src, readPtr)
- CONST char *src; /* Points to the backslash character of
- * a backslash sequence. */
- int *readPtr; /* Fill in with number of characters read
- * from src, unless NULL. */
+ CONST char *src; /* Points to the backslash character of a
+ * backslash sequence. */
+ int *readPtr; /* Fill in with number of characters read from
+ * src, unless NULL. */
{
char buf[TCL_UTF_MAX];
Tcl_UniChar ch;
@@ -976,13 +960,13 @@ Tcl_Backslash(src, readPtr)
* Concatenate a set of strings into a single large string.
*
* Results:
- * The return value is dynamically-allocated string containing
- * a concatenation of all the strings in argv, with spaces between
- * the original argv elements.
+ * The return value is dynamically-allocated string containing a
+ * concatenation of all the strings in argv, with spaces between the
+ * original argv elements.
*
* Side effects:
- * Memory is allocated for the result; the caller is responsible
- * for freeing the memory.
+ * Memory is allocated for the result; the caller is responsible for
+ * freeing the memory.
*
*----------------------------------------------------------------------
*/
@@ -1009,9 +993,8 @@ Tcl_Concat(argc, argv)
int length;
/*
- * Clip white space off the front and back of the string
- * to generate a neater result, and ignore any empty
- * elements.
+ * Clip white space off the front and back of the string to generate a
+ * neater result, and ignore any empty elements.
*/
element = argv[i];
@@ -1022,7 +1005,7 @@ Tcl_Concat(argc, argv)
(length > 0)
&& (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */
&& ((length < 2) || (element[length-2] != '\\'));
- length--) {
+ length--) {
/* Null loop body. */
}
if (length == 0) {
@@ -1050,8 +1033,8 @@ Tcl_Concat(argc, argv)
* object with spaces between the original strings.
*
* Results:
- * The return value is a new string object containing a concatenation
- * of the strings in objv. Its ref count is zero.
+ * The return value is a new string object containing a concatenation of
+ * the strings in objv. Its ref count is zero.
*
* Side effects:
* A new object is created.
@@ -1071,13 +1054,13 @@ Tcl_ConcatObj(objc, objv)
Tcl_Obj *objPtr;
/*
- * Check first to see if all the items are of list type. If so,
- * we will concat them together as lists, and return a list object.
- * This is only valid when the lists have no current string
- * representation, since we don't know what the original type was.
- * An original string rep may have lost some whitespace info when
- * converted which could be important.
+ * Check first to see if all the items are of list type. If so, we will
+ * concat them together as lists, and return a list object. This is only
+ * valid when the lists have no current string representation, since we
+ * don't know what the original type was. An original string rep may have
+ * lost some whitespace info when converted which could be important.
*/
+
for (i = 0; i < objc; i++) {
objPtr = objv[i];
if ((objPtr->typePtr != &tclListType) || (objPtr->bytes != NULL)) {
@@ -1091,10 +1074,10 @@ Tcl_ConcatObj(objc, objv)
objPtr = Tcl_NewListObj(0, NULL);
for (i = 0; i < objc; i++) {
/*
- * Tcl_ListObjAppendList could be used here, but this saves
- * us a bit of type checking (since we've already done it)
- * Use of INT_MAX tells us to always put the new stuff on
- * the end. It will be set right in Tcl_ListObjReplace.
+ * Tcl_ListObjAppendList could be used here, but this saves us a
+ * bit of type checking (since we've already done it). Use of
+ * INT_MAX tells us to always put the new stuff on the end. It
+ * will be set right in Tcl_ListObjReplace.
*/
Tcl_ListObjGetElements(NULL, objv[i], &listc, &listv);
Tcl_ListObjReplace(NULL, objPtr, INT_MAX, 0, listc, listv);
@@ -1102,6 +1085,11 @@ Tcl_ConcatObj(objc, objv)
return objPtr;
}
+ /*
+ * Something cannot be determined to be safe, so build the concatenation
+ * the slow way, using the string representations.
+ */
+
allocSize = 0;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
@@ -1115,17 +1103,17 @@ Tcl_ConcatObj(objc, objv)
}
/*
- * Allocate storage for the concatenated result. Note that allocSize
- * is one more than the total number of characters, and so includes
- * room for the terminating NULL byte.
+ * Allocate storage for the concatenated result. Note that allocSize is
+ * one more than the total number of characters, and so includes room for
+ * the terminating NULL byte.
*/
-
+
concatStr = (char *) ckalloc((unsigned) allocSize);
/*
* Now concatenate the elements. Clip white space off the front and back
- * to generate a neater result, and ignore any empty elements. Also put
- * a null byte at the end.
+ * to generate a neater result, and ignore any empty elements. Also put a
+ * null byte at the end.
*/
finalSize = 0;
@@ -1133,19 +1121,19 @@ Tcl_ConcatObj(objc, objv)
*concatStr = '\0';
} else {
p = concatStr;
- for (i = 0; i < objc; i++) {
+ for (i = 0; i < objc; i++) {
objPtr = objv[i];
element = Tcl_GetStringFromObj(objPtr, &elemLength);
while ((elemLength > 0) && (UCHAR(*element) < 127)
&& isspace(UCHAR(*element))) { /* INTL: ISO C space. */
- element++;
- elemLength--;
+ element++;
+ elemLength--;
}
/*
- * Trim trailing white space. But, be careful not to trim
- * a space character if it is preceded by a backslash: in
- * this case it could be significant.
+ * Trim trailing white space. But, be careful not to trim a space
+ * character if it is preceded by a backslash: in this case it
+ * could be significant.
*/
while ((elemLength > 0) && (UCHAR(element[elemLength-1]) < 127)
@@ -1154,22 +1142,22 @@ Tcl_ConcatObj(objc, objv)
elemLength--;
}
if (elemLength == 0) {
- continue; /* nothing left of this element */
+ continue; /* nothing left of this element */
}
memcpy((VOID *) p, (VOID *) element, (size_t) elemLength);
p += elemLength;
*p = ' ';
p++;
finalSize += (elemLength + 1);
- }
- if (p != concatStr) {
+ }
+ if (p != concatStr) {
p[-1] = 0;
finalSize -= 1; /* we overwrote the final ' ' */
- } else {
+ } else {
*p = 0;
- }
+ }
}
-
+
TclNewObj(objPtr);
objPtr->bytes = concatStr;
objPtr->length = finalSize;
@@ -1184,10 +1172,9 @@ Tcl_ConcatObj(objc, objv)
* See if a particular string matches a particular pattern.
*
* Results:
- * The return value is 1 if string matches pattern, and
- * 0 otherwise. The matching operation permits the following
- * special characters in the pattern: *?\[] (see the manual
- * entry for details on what these mean).
+ * The return value is 1 if string matches pattern, and 0 otherwise. The
+ * matching operation permits the following special characters in the
+ * pattern: *?\[] (see the manual entry for details on what these mean).
*
* Side effects:
* None.
@@ -1209,14 +1196,13 @@ Tcl_StringMatch(str, pattern)
*
* Tcl_StringCaseMatch --
*
- * See if a particular string matches a particular pattern.
- * Allows case insensitivity.
+ * See if a particular string matches a particular pattern. Allows case
+ * insensitivity.
*
* Results:
- * The return value is 1 if string matches pattern, and
- * 0 otherwise. The matching operation permits the following
- * special characters in the pattern: *?\[] (see the manual
- * entry for details on what these mean).
+ * The return value is 1 if string matches pattern, and 0 otherwise. The
+ * matching operation permits the following special characters in the
+ * pattern: *?\[] (see the manual entry for details on what these mean).
*
* Side effects:
* None.
@@ -1234,16 +1220,16 @@ Tcl_StringCaseMatch(str, pattern, nocase)
int p, charLen;
CONST char *pstart = pattern;
Tcl_UniChar ch1, ch2;
-
+
while (1) {
p = *pattern;
-
+
/*
- * See if we're at the end of both the pattern and the string. If
- * so, we succeeded. If we're at the end of the pattern but not at
- * the end of the string, we failed.
+ * See if we're at the end of both the pattern and the string. If so,
+ * we succeeded. If we're at the end of the pattern but not at the end
+ * of the string, we failed.
*/
-
+
if (p == '\0') {
return (*str == '\0');
}
@@ -1252,24 +1238,27 @@ Tcl_StringCaseMatch(str, pattern, nocase)
}
/*
- * Check for a "*" as the next pattern character. It matches
- * any substring. We handle this by calling ourselves
- * recursively for each postfix of string, until either we
- * match or we reach the end of the string.
+ * Check for a "*" as the next pattern character. It matches any
+ * substring. We handle this by calling ourselves recursively for each
+ * postfix of string, until either we match or we reach the end of the
+ * string.
*/
-
+
if (p == '*') {
/*
* Skip all successive *'s in the pattern
*/
+
while (*(++pattern) == '*') {}
p = *pattern;
if (p == '\0') {
return 1;
}
+
/*
* This is a special case optimization for single-byte utf.
*/
+
if (UCHAR(*pattern) < 0x80) {
ch2 = (Tcl_UniChar)
(nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
@@ -1278,6 +1267,7 @@ Tcl_StringCaseMatch(str, pattern, nocase)
if (nocase) {
ch2 = Tcl_UniCharToLower(ch2);
}
+
}
while (1) {
/*
@@ -1285,6 +1275,7 @@ Tcl_StringCaseMatch(str, pattern, nocase)
* quickly if the next char in the pattern isn't a special
* character
*/
+
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*str) {
@@ -1297,9 +1288,10 @@ Tcl_StringCaseMatch(str, pattern, nocase)
} else {
/*
* There's no point in trying to make this code
- * shorter, as the number of bytes you want to
- * compare each time is non-constant.
+ * shorter, as the number of bytes you want to compare
+ * each time is non-constant.
*/
+
while (*str) {
charLen = TclUtfToUniChar(str, &ch1);
if (ch2 == ch1) {
@@ -1320,8 +1312,8 @@ Tcl_StringCaseMatch(str, pattern, nocase)
}
/*
- * Check for a "?" as the next pattern character. It matches
- * any single character.
+ * Check for a "?" as the next pattern character. It matches any
+ * single character.
*/
if (p == '?') {
@@ -1331,9 +1323,9 @@ Tcl_StringCaseMatch(str, pattern, nocase)
}
/*
- * Check for a "[" as the next pattern character. It is followed
- * by a list of characters that are acceptable, or by a range
- * (two characters separated by "-").
+ * Check for a "[" as the next pattern character. It is followed by a
+ * list of characters that are acceptable, or by a range (two
+ * characters separated by "-").
*/
if (p == '[') {
@@ -1404,8 +1396,8 @@ Tcl_StringCaseMatch(str, pattern, nocase)
}
/*
- * If the next pattern character is '\', just strip off the '\'
- * so we do exact matching on the character that follows.
+ * If the next pattern character is '\', just strip off the '\' so we
+ * do exact matching on the character that follows.
*/
if (p == '\\') {
@@ -1416,8 +1408,8 @@ Tcl_StringCaseMatch(str, pattern, nocase)
}
/*
- * There's no special character. Just make sure that the next
- * bytes of each string match.
+ * There's no special character. Just make sure that the next bytes of
+ * each string match.
*/
str += TclUtfToUniChar(str, &ch1);
@@ -1437,9 +1429,9 @@ Tcl_StringCaseMatch(str, pattern, nocase)
*
* Tcl_DStringInit --
*
- * Initializes a dynamic string, discarding any previous contents
- * of the string (Tcl_DStringFree should have been called already
- * if the dynamic string was previously in use).
+ * Initializes a dynamic string, discarding any previous contents of the
+ * string (Tcl_DStringFree should have been called already if the dynamic
+ * string was previously in use).
*
* Results:
* None.
@@ -1471,9 +1463,9 @@ Tcl_DStringInit(dsPtr)
* The return value is a pointer to the dynamic string's new value.
*
* Side effects:
- * Length bytes from "bytes" (or all of "bytes" if length is less
- * than zero) are added to the current value of the string. Memory
- * gets reallocated if needed to accomodate the string's new size.
+ * Length bytes from "bytes" (or all of "bytes" if length is less than
+ * zero) are added to the current value of the string. Memory gets
+ * reallocated if needed to accomodate the string's new size.
*
*----------------------------------------------------------------------
*/
@@ -1481,11 +1473,11 @@ Tcl_DStringInit(dsPtr)
char *
Tcl_DStringAppend(dsPtr, bytes, length)
Tcl_DString *dsPtr; /* Structure describing dynamic string. */
- CONST char *bytes; /* String to append. If length is -1 then
- * this must be null-terminated. */
- int length; /* Number of bytes from "bytes" to
- * append. If < 0, then append all of bytes,
- * up to null at end. */
+ CONST char *bytes; /* String to append. If length is -1 then this
+ * must be null-terminated. */
+ int length; /* Number of bytes from "bytes" to append. If
+ * < 0, then append all of bytes, up to null
+ * at end. */
{
int newSize;
char *dst;
@@ -1497,9 +1489,9 @@ Tcl_DStringAppend(dsPtr, bytes, length)
newSize = length + dsPtr->length;
/*
- * Allocate a larger buffer for the string if the current one isn't
- * large enough. Allocate extra space in the new buffer so that there
- * will be room to grow before we have to allocate again.
+ * Allocate a larger buffer for the string if the current one isn't large
+ * enough. Allocate extra space in the new buffer so that there will be
+ * room to grow before we have to allocate again.
*/
if (newSize >= dsPtr->spaceAvl) {
@@ -1518,8 +1510,7 @@ Tcl_DStringAppend(dsPtr, bytes, length)
}
/*
- * Copy the new string into the buffer at the end of the old
- * one.
+ * Copy the new string into the buffer at the end of the old one.
*/
for (dst = dsPtr->string + dsPtr->length, end = bytes+length;
@@ -1542,9 +1533,9 @@ Tcl_DStringAppend(dsPtr, bytes, length)
* The return value is a pointer to the dynamic string's new value.
*
* Side effects:
- * String is reformatted as a list element and added to the current
- * value of the string. Memory gets reallocated if needed to
- * accomodate the string's new size.
+ * String is reformatted as a list element and added to the current value
+ * of the string. Memory gets reallocated if needed to accomodate the
+ * string's new size.
*
*----------------------------------------------------------------------
*/
@@ -1552,7 +1543,7 @@ Tcl_DStringAppend(dsPtr, bytes, length)
char *
Tcl_DStringAppendElement(dsPtr, element)
Tcl_DString *dsPtr; /* Structure describing dynamic string. */
- CONST char *element; /* String to append. Must be
+ CONST char *element; /* String to append. Must be
* null-terminated. */
{
int newSize, flags, strSize;
@@ -1563,12 +1554,11 @@ Tcl_DStringAppendElement(dsPtr, element)
+ dsPtr->length + 1;
/*
- * Allocate a larger buffer for the string if the current one isn't
- * large enough. Allocate extra space in the new buffer so that there
- * will be room to grow before we have to allocate again.
- * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string
- * to a larger buffer, since there may be embedded NULLs in the
- * string in some cases.
+ * Allocate a larger buffer for the string if the current one isn't large
+ * enough. Allocate extra space in the new buffer so that there will be
+ * room to grow before we have to allocate again. SPECIAL NOTE: must use
+ * memcpy, not strcpy, to copy the string to a larger buffer, since there
+ * may be embedded NULLs in the string in some cases.
*/
if (newSize >= dsPtr->spaceAvl) {
@@ -1587,8 +1577,8 @@ Tcl_DStringAppendElement(dsPtr, element)
}
/*
- * Convert the new string to a list element and copy it into the
- * buffer at the end, with a space, if needed.
+ * Convert the new string to a list element and copy it into the buffer at
+ * the end, with a space, if needed.
*/
dst = dsPtr->string + dsPtr->length;
@@ -1596,11 +1586,13 @@ Tcl_DStringAppendElement(dsPtr, element)
*dst = ' ';
dst++;
dsPtr->length++;
+
/*
- * If we need a space to separate this element from preceding
- * stuff, then this element will not lead a list, and need not
- * have it's leading '#' quoted.
+ * If we need a space to separate this element from preceding stuff,
+ * then this element will not lead a list, and need not have it's
+ * leading '#' quoted.
*/
+
flags |= TCL_DONT_QUOTE_HASH;
}
dsPtr->length += Tcl_ConvertCountedElement(element, strSize, dst, flags);
@@ -1612,17 +1604,16 @@ Tcl_DStringAppendElement(dsPtr, element)
*
* Tcl_DStringSetLength --
*
- * Change the length of a dynamic string. This can cause the
- * string to either grow or shrink, depending on the value of
- * length.
+ * Change the length of a dynamic string. This can cause the string to
+ * either grow or shrink, depending on the value of length.
*
* Results:
* None.
*
* Side effects:
- * The length of dsPtr is changed to length and a null byte is
- * stored at that position in the string. If length is larger
- * than the space allocated for dsPtr, then a panic occurs.
+ * The length of dsPtr is changed to length and a null byte is stored at
+ * that position in the string. If length is larger than the space
+ * allocated for dsPtr, then a panic occurs.
*
*----------------------------------------------------------------------
*/
@@ -1639,15 +1630,15 @@ Tcl_DStringSetLength(dsPtr, length)
}
if (length >= dsPtr->spaceAvl) {
/*
- * There are two interesting cases here. In the first case, the user
- * may be trying to allocate a large buffer of a specific size. It
+ * There are two interesting cases here. In the first case, the user
+ * may be trying to allocate a large buffer of a specific size. It
* would be wasteful to overallocate that buffer, so we just allocate
- * enough for the requested size plus the trailing null byte. In the
+ * enough for the requested size plus the trailing null byte. In the
* second case, we are growing the buffer incrementally, so we need
- * behavior similar to Tcl_DStringAppend. The requested length will
- * usually be a small delta above the current spaceAvl, so we'll end up
- * doubling the old size. This won't grow the buffer quite as quickly,
- * but it should be close enough.
+ * behavior similar to Tcl_DStringAppend. The requested length will
+ * usually be a small delta above the current spaceAvl, so we'll end
+ * up doubling the old size. This won't grow the buffer quite as
+ * quickly, but it should be close enough.
*/
newsize = dsPtr->spaceAvl * 2;
@@ -1677,17 +1668,18 @@ Tcl_DStringSetLength(dsPtr, length)
*
* Tcl_DStringFree --
*
- * Frees up any memory allocated for the dynamic string and
- * reinitializes the string to an empty state.
+ * Frees up any memory allocated for the dynamic string and reinitializes
+ * the string to an empty state.
*
* Results:
* None.
*
* Side effects:
- * The previous contents of the dynamic string are lost, and
- * the new value is an empty string.
+ * The previous contents of the dynamic string are lost, and the new
+ * value is an empty string.
*
- *---------------------------------------------------------------------- */
+ *----------------------------------------------------------------------
+ */
void
Tcl_DStringFree(dsPtr)
@@ -1707,17 +1699,16 @@ Tcl_DStringFree(dsPtr)
*
* Tcl_DStringResult --
*
- * This procedure moves the value of a dynamic string into an
- * interpreter as its string result. Afterwards, the dynamic string
- * is reset to an empty string.
+ * This function moves the value of a dynamic string into an interpreter
+ * as its string result. Afterwards, the dynamic string is reset to an
+ * empty string.
*
* Results:
* None.
*
* Side effects:
- * The string is "moved" to interp's result, and any existing
- * string result for interp is freed. dsPtr is reinitialized to
- * an empty string.
+ * The string is "moved" to interp's result, and any existing string
+ * result for interp is freed. dsPtr is reinitialized to an empty string.
*
*----------------------------------------------------------------------
*/
@@ -1729,7 +1720,7 @@ Tcl_DStringResult(interp, dsPtr)
* result of interp. */
{
Tcl_ResetResult(interp);
-
+
if (dsPtr->string != dsPtr->staticSpace) {
interp->result = dsPtr->string;
interp->freeProc = TCL_DYNAMIC;
@@ -1739,7 +1730,7 @@ Tcl_DStringResult(interp, dsPtr)
} else {
Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE);
}
-
+
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
@@ -1751,14 +1742,14 @@ Tcl_DStringResult(interp, dsPtr)
*
* Tcl_DStringGetResult --
*
- * This procedure moves an interpreter's result into a dynamic string.
+ * This function moves an interpreter's result into a dynamic string.
*
* Results:
* None.
*
* Side effects:
- * The interpreter's string result is cleared, and the previous
- * contents of dsPtr are freed.
+ * The interpreter's string result is cleared, and the previous contents
+ * of dsPtr are freed.
*
* If the string result is empty, the object result is moved to the
* string result, then the object result is reset.
@@ -1769,18 +1760,18 @@ Tcl_DStringResult(interp, dsPtr)
void
Tcl_DStringGetResult(interp, dsPtr)
Tcl_Interp *interp; /* Interpreter whose result is to be reset. */
- Tcl_DString *dsPtr; /* Dynamic string that is to become the
- * result of interp. */
+ Tcl_DString *dsPtr; /* Dynamic string that is to become the result
+ * of interp. */
{
Interp *iPtr = (Interp *) interp;
-
+
if (dsPtr->string != dsPtr->staticSpace) {
ckfree(dsPtr->string);
}
/*
- * If the string result is empty, move the object result to the
- * string result, then reset the object result.
+ * If the string result is empty, move the object result to the string
+ * result, then reset the object result.
*/
(void) Tcl_GetStringResult(interp);
@@ -1807,7 +1798,7 @@ Tcl_DStringGetResult(interp, dsPtr)
}
strcpy(dsPtr->string, iPtr->result);
}
-
+
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
}
@@ -1817,9 +1808,9 @@ Tcl_DStringGetResult(interp, dsPtr)
*
* Tcl_DStringStartSublist --
*
- * This procedure adds the necessary information to a dynamic
- * string (e.g. " {" to start a sublist. Future element
- * appends will be in the sublist rather than the main list.
+ * This function adds the necessary information to a dynamic string
+ * (e.g. " {") to start a sublist. Future element appends will be in the
+ * sublist rather than the main list.
*
* Results:
* None.
@@ -1832,7 +1823,7 @@ Tcl_DStringGetResult(interp, dsPtr)
void
Tcl_DStringStartSublist(dsPtr)
- Tcl_DString *dsPtr; /* Dynamic string. */
+ Tcl_DString *dsPtr; /* Dynamic string. */
{
if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) {
Tcl_DStringAppend(dsPtr, " {", -1);
@@ -1846,10 +1837,9 @@ Tcl_DStringStartSublist(dsPtr)
*
* Tcl_DStringEndSublist --
*
- * This procedure adds the necessary characters to a dynamic
- * string to end a sublist (e.g. "}"). Future element appends
- * will be in the enclosing (sub)list rather than the current
- * sublist.
+ * This function adds the necessary characters to a dynamic string to end
+ * a sublist (e.g. "}"). Future element appends will be in the enclosing
+ * (sub)list rather than the current sublist.
*
* Results:
* None.
@@ -1862,7 +1852,7 @@ Tcl_DStringStartSublist(dsPtr)
void
Tcl_DStringEndSublist(dsPtr)
- Tcl_DString *dsPtr; /* Dynamic string. */
+ Tcl_DString *dsPtr; /* Dynamic string. */
{
Tcl_DStringAppend(dsPtr, "}", -1);
}
@@ -1872,14 +1862,14 @@ Tcl_DStringEndSublist(dsPtr)
*
* Tcl_PrintDouble --
*
- * Given a floating-point value, this procedure converts it to
- * an ASCII string using.
+ * Given a floating-point value, this function converts it to an ASCII
+ * string using.
*
* Results:
- * The ASCII equivalent of "value" is written at "dst". It is
- * written using the current precision, and it is guaranteed to
- * contain a decimal point or exponent, so that it looks like
- * a floating-point value and not an integer.
+ * The ASCII equivalent of "value" is written at "dst". It is written
+ * using the current precision, and it is guaranteed to contain a decimal
+ * point or exponent, so that it looks like a floating-point value and
+ * not an integer.
*
* Side effects:
* None.
@@ -1889,13 +1879,12 @@ Tcl_DStringEndSublist(dsPtr)
void
Tcl_PrintDouble(interp, value, dst)
- Tcl_Interp *interp; /* Interpreter whose tcl_precision
- * variable used to be used to control
- * printing. It's ignored now. */
- double value; /* Value to print as string. */
- char *dst; /* Where to store converted value;
- * must have at least TCL_DOUBLE_SPACE
- * characters. */
+ Tcl_Interp *interp; /* Interpreter whose tcl_precision variable
+ * used to be used to control printing. It's
+ * ignored now. */
+ double value; /* Value to print as string. */
+ char *dst; /* Where to store converted value; must have
+ * at least TCL_DOUBLE_SPACE characters. */
{
char *p, c;
int prec;
@@ -1909,64 +1898,71 @@ Tcl_PrintDouble(interp, value, dst)
Tcl_MutexUnlock(&precisionMutex);
/*
- * If prec == 0, then use TclDoubleDigits to develop a decimal
- * significand and exponent, then format it in E or F format as
- * appropriate. If prec != 0, use the native sprintf and then
- * add a trailing ".0" if there is no decimal point in the rep.
+ * If prec == 0, then use TclDoubleDigits to develop a decimal significand
+ * and exponent, then format it in E or F format as appropriate. If prec
+ * != 0, use the native sprintf and then add a trailing ".0" if there is
+ * no decimal point in the rep.
*/
if ( prec == 0 ) {
+ /*
+ * Handle NaN.
+ */
- /* Handle NaN */
-
- if ( IS_NAN( value ) ) {
- TclFormatNaN( value, dst );
+ if (IS_NAN(value)) {
+ TclFormatNaN(value, dst);
return;
}
- /* Handle infinities */
+ /*
+ * Handle infinities.
+ */
- if ( IS_INF( value ) ) {
- if ( value < 0 ) {
- strcpy( dst, "-Inf" );
+ if (IS_INF(value)) {
+ if (value < 0) {
+ strcpy(dst, "-Inf");
} else {
- strcpy( dst, "Inf" );
+ strcpy(dst, "Inf");
}
return;
}
- /* Ordinary (normal and denormal) values */
+ /*
+ * Ordinary (normal and denormal) values.
+ */
- exp = TclDoubleDigits( buffer, value, &signum );
- if ( signum ) {
+ exp = TclDoubleDigits(buffer, value, &signum);
+ if (signum) {
*dst++ = '-';
}
- prec = strlen( buffer );
+ prec = strlen(buffer);
p = buffer;
- if ( exp < -3 || exp > 17 ) {
-
- /* E format for numbers < 1e-3 or >= 1e17 */
+ if (exp < -3 || exp > 17) {
+ /*
+ * E format for numbers < 1e-3 or >= 1e17.
+ */
*dst++ = *p++;
c = *p;
- if ( c != '\0' ) {
+ if (c != '\0') {
*dst++ = '.';
- while ( c != '\0' ) {
+ while (c != '\0') {
*dst++ = c;
c = *++p;
}
}
- sprintf( dst, "e%+d", exp-1 );
+ sprintf(dst, "e%+d", exp-1);
} else {
+ /*
+ * F format for others.
+ */
- /* F format for others */
-
- if ( exp <= 0 ) {
+ if (exp <= 0) {
*dst++ = '0';
}
c = *p;
- while ( exp-- > 0 ) {
- if ( c != '\0' ) {
+ while (exp-- > 0) {
+ if (c != '\0') {
*dst++ = c;
c = *++p;
} else {
@@ -1974,13 +1970,13 @@ Tcl_PrintDouble(interp, value, dst)
}
}
*dst++ = '.';
- if ( c == '\0' ) {
+ if (c == '\0') {
*dst++ = '0';
} else {
- while ( ++exp < 0 ) {
+ while (++exp < 0) {
*dst++ = '0';
}
- while ( c != '\0' ) {
+ while (c != '\0') {
*dst++ = c;
c = *++p;
}
@@ -1989,18 +1985,19 @@ Tcl_PrintDouble(interp, value, dst)
}
} else {
+ /*
+ * tcl_precision is supplied, pass it to the native sprintf.
+ */
- /* tcl_precision is supplied, pass it to the native sprintf */
+ sprintf(dst, "%.*g", prec, value);
- sprintf( dst, "%.*g", prec, value );
-
/*
* If the ASCII result looks like an integer, add ".0" so that it
- * doesn't look like an integer anymore. This prevents floating-point
- * values from being converted to integers unintentionally.
- * Check for ASCII specifically to speed up the function.
+ * doesn't look like an integer anymore. This prevents floating-point
+ * values from being converted to integers unintentionally. Check for
+ * ASCII specifically to speed up the function.
*/
-
+
for (p = dst; *p != 0; ) {
if (UCHAR(*p) < 0x80) {
c = *p++;
@@ -2024,17 +2021,17 @@ Tcl_PrintDouble(interp, value, dst)
*
* TclPrecTraceProc --
*
- * This procedure is invoked whenever the variable "tcl_precision"
- * is written.
+ * This function is invoked whenever the variable "tcl_precision" is
+ * written.
*
* Results:
- * Returns NULL if all went well, or an error message if the
- * new value for the variable doesn't make sense.
+ * Returns NULL if all went well, or an error message if the new value
+ * for the variable doesn't make sense.
*
* Side effects:
- * If the new value doesn't make sense then this procedure
- * undoes the effect of the variable modification. Otherwise
- * it modifies the format string that's used by Tcl_PrintDouble.
+ * If the new value doesn't make sense then this function undoes the
+ * effect of the variable modification. Otherwise it modifies the format
+ * string that's used by Tcl_PrintDouble.
*
*----------------------------------------------------------------------
*/
@@ -2065,43 +2062,40 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags)
}
/*
- * When the variable is read, reset its value from our shared
- * value. This is needed in case the variable was modified in
- * some other interpreter so that this interpreter's value is
- * out of date.
+ * When the variable is read, reset its value from our shared value. This
+ * is needed in case the variable was modified in some other interpreter
+ * so that this interpreter's value is out of date.
*/
if (flags & TCL_TRACE_READS) {
Tcl_MutexLock(&precisionMutex);
- Tcl_SetVar2Ex( interp, name1, name2, Tcl_NewIntObj( precision ),
- flags & TCL_GLOBAL_ONLY );
+ Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewIntObj(precision),
+ flags & TCL_GLOBAL_ONLY);
Tcl_MutexUnlock(&precisionMutex);
return (char *) NULL;
}
/*
- * The variable is being written. Check the new value and disallow
- * it if it isn't reasonable or if this is a safe interpreter (we
- * don't want safe interpreters messing up the precision of other
- * interpreters).
+ * The variable is being written. Check the new value and disallow it if
+ * it isn't reasonable or if this is a safe interpreter (we don't want
+ * safe interpreters messing up the precision of other interpreters).
*/
if (Tcl_IsSafe(interp)) {
Tcl_MutexLock(&precisionMutex);
- Tcl_SetVar2Ex( interp, name1, name2, Tcl_NewIntObj( precision ),
- flags & TCL_GLOBAL_ONLY );
+ Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewIntObj(precision),
+ flags & TCL_GLOBAL_ONLY);
Tcl_MutexUnlock(&precisionMutex);
return "can't modify precision from a safe interpreter";
}
value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
- if ( value == NULL
- || Tcl_GetIntFromObj( (Tcl_Interp*) NULL, value, &prec ) != TCL_OK
- || prec < 0
- || prec > TCL_MAX_PREC ) {
+ if (value == NULL
+ || Tcl_GetIntFromObj((Tcl_Interp*) NULL, value, &prec) != TCL_OK
+ || prec < 0 || prec > TCL_MAX_PREC) {
return "improper value for precision";
}
- Tcl_MutexLock( &precisionMutex );
+ Tcl_MutexLock(&precisionMutex);
precision = prec;
Tcl_MutexUnlock(&precisionMutex);
return (char *) NULL;
@@ -2112,9 +2106,8 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags)
*
* TclNeedSpace --
*
- * This procedure checks to see whether it is appropriate to
- * add a space before appending a new list element to an
- * existing string.
+ * This function checks to see whether it is appropriate to add a space
+ * before appending a new list element to an existing string.
*
* Results:
* The return value is 1 if a space is appropriate, 0 otherwise.
@@ -2128,22 +2121,23 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags)
int
TclNeedSpace(start, end)
CONST char *start; /* First character in string. */
- CONST char *end; /* End of string (place where space will
- * be added, if appropriate). */
+ CONST char *end; /* End of string (place where space will be
+ * added, if appropriate). */
{
/*
- * A space is needed unless either
+ * A space is needed unless either:
* (a) we're at the start of the string, or
*/
+
if (end == start) {
return 0;
}
/*
- * (b) we're at the start of a nested list-element, quoted with an
- * open curly brace; we can be nested arbitrarily deep, so long
- * as the first curly brace starts an element, so backtrack over
- * open curly braces that are trailing characters of the string; and
+ * (b) we're at the start of a nested list-element, quoted with an open
+ * curly brace; we can be nested arbitrarily deep, so long as the
+ * first curly brace starts an element, so backtrack over open curly
+ * braces that are trailing characters of the string; and
*/
end = Tcl_UtfPrev(end, start);
@@ -2156,39 +2150,39 @@ TclNeedSpace(start, end)
/*
* (c) the trailing character of the string is already a list-element
- * separator (according to TclFindElement); that is, one of these
- * characters:
- * \u0009 \t TAB
- * \u000A \n NEWLINE
- * \u000B \v VERTICAL TAB
- * \u000C \f FORM FEED
- * \u000D \r CARRIAGE RETURN
- * \u0020 SPACE
- * with the condition that the penultimate character is not a
- * backslash.
+ * separator (according to TclFindElement); that is, one of these
+ * characters:
+ * \u0009 \t TAB
+ * \u000A \n NEWLINE
+ * \u000B \v VERTICAL TAB
+ * \u000C \f FORM FEED
+ * \u000D \r CARRIAGE RETURN
+ * \u0020 SPACE
+ * with the condition that the penultimate character is not a
+ * backslash.
*/
if (*end > 0x20) {
/*
- * Performance tweak. All ASCII spaces are <= 0x20. So get
- * a quick answer for most characters before comparing against
- * all spaces in the switch below.
+ * Performance tweak. All ASCII spaces are <= 0x20. So get a quick
+ * answer for most characters before comparing against all spaces in
+ * the switch below.
*
- * NOTE: Remove this if other Unicode spaces ever get accepted
- * as list-element separators.
+ * NOTE: Remove this if other Unicode spaces ever get accepted as
+ * list-element separators.
*/
return 1;
}
switch (*end) {
- case ' ':
- case '\t':
- case '\n':
- case '\r':
- case '\v':
- case '\f':
- if ((end == start) || (end[-1] != '\\')) {
- return 0;
- }
+ case ' ':
+ case '\t':
+ case '\n':
+ case '\r':
+ case '\v':
+ case '\f':
+ if ((end == start) || (end[-1] != '\\')) {
+ return 0;
+ }
}
return 1;
}
@@ -2198,15 +2192,15 @@ TclNeedSpace(start, end)
*
* TclLooksLikeInt --
*
- * This procedure decides whether the leading characters of a
- * string look like an integer or something else (such as a
- * floating-point number or string).
+ * This function decides whether the leading characters of a string look
+ * like an integer or something else (such as a floating-point number or
+ * string).
*
* Results:
- * The return value is 1 if the leading characters of p look
- * like a valid Tcl integer. If they look like a floating-point
- * number (e.g. "e01" or "2.4"), or if they don't look like a
- * number at all, then 0 is returned.
+ * The return value is 1 if the leading characters of p look like a valid
+ * Tcl integer. If they look like a floating-point number (e.g. "e01" or
+ * "2.4"), or if they don't look like a number at all, then 0 is
+ * returned.
*
* Side effects:
* None.
@@ -2217,10 +2211,9 @@ TclNeedSpace(start, end)
int
TclLooksLikeInt(bytes, length)
register CONST char *bytes; /* Points to first byte of the string. */
- int length; /* Number of bytes in the string. If < 0
- * bytes up to the first null byte are
- * considered (if they may appear in an
- * integer). */
+ int length; /* Number of bytes in the string. If < 0 bytes
+ * up to the first null byte are considered
+ * (if they may appear in an integer). */
{
register CONST char *p;
@@ -2229,7 +2222,7 @@ TclLooksLikeInt(bytes, length)
}
if (length < 0) {
- length = (bytes? strlen(bytes) : 0);
+ length = (bytes? strlen(bytes) : 0);
}
p = bytes;
@@ -2237,10 +2230,11 @@ TclLooksLikeInt(bytes, length)
length--; p++;
}
if (length == 0) {
- return 0;
+ return 0;
}
if ((*p == '+') || (*p == '-')) {
- p++; length--;
+ p++;
+ length--;
}
return (0 != TclParseInteger(p, length));
@@ -2251,33 +2245,32 @@ TclLooksLikeInt(bytes, length)
*
* TclGetIntForIndex --
*
- * This procedure 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)?.
+ * 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.
+ * 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.
+ * The object referenced by "objPtr" might be converted to an integer,
+ * wide integer, or end-based-index object.
*
*----------------------------------------------------------------------
*/
int
TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
- Tcl_Interp *interp; /* Interpreter to use for error reporting.
- * If NULL, then no error message is left
- * after errors. */
- Tcl_Obj *objPtr; /* Points to an object containing either
- * "end" or an integer. */
+ Tcl_Interp *interp; /* Interpreter to use for error reporting. If
+ * NULL, then no error message is left after
+ * errors. */
+ Tcl_Obj *objPtr; /* Points to an object containing either "end"
+ * or an integer. */
int endValue; /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
int *indexPtr; /* Location filled in with an integer
@@ -2289,8 +2282,8 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) {
/*
- * If the object is already an offset from the end of the
- * list, or can be converted to one, use it.
+ * If the object is already an offset from the end of the list, or can
+ * be converted to one, use it.
*/
*indexPtr = endValue + objPtr->internalRep.longValue;
@@ -2304,7 +2297,7 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
length--; p++;
}
if (length == 0) {
- goto parseError;
+ goto parseError;
}
if ((*p == '+') || (*p == '-')) {
p++; length--;
@@ -2340,14 +2333,16 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
* Report a parse error.
*/
-parseError:
+ parseError:
if (interp != NULL) {
char *bytes = Tcl_GetString(objPtr);
+
/*
- * The result might not be empty; this resets it which
- * should be both a cheap operation, and of little problem
- * because this is an error-generation path anyway.
+ * The result might not be empty; this resets it which should be
+ * both a cheap operation, and of little problem because this is
+ * an error-generation path anyway.
*/
+
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad index \"", bytes,
"\": must be integer?[+-]integer? or end?[+-]integer?",
@@ -2360,7 +2355,7 @@ parseError:
return TCL_ERROR;
}
-
+
return TCL_OK;
}
@@ -2378,9 +2373,8 @@ parseError:
* Side effects:
* Stores a valid string in the object's string rep.
*
- * This procedure does NOT free any earlier string rep. If it is
- * called on an object that already has a valid string rep, it will
- * leak memory.
+ * This function does NOT free any earlier string rep. If it is called on an
+ * object that already has a valid string rep, it will leak memory.
*
*----------------------------------------------------------------------
*/
@@ -2408,35 +2402,39 @@ UpdateStringOfEndOffset(objPtr)
*
* SetEndOffsetFromAny --
*
- * Look for a string of the form "end[+-]offset" and convert it
- * to an internal representation holding the offset.
+ * Look for a string of the form "end[+-]offset" and convert it to an
+ * internal representation holding the offset.
*
* Results:
* Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
*
* Side effects:
- * If interp is not NULL, stores an error message in the
- * interpreter result.
+ * If interp is not NULL, stores an error message in the interpreter
+ * result.
*
*----------------------------------------------------------------------
*/
static int
SetEndOffsetFromAny(interp, objPtr)
- Tcl_Interp* interp; /* Tcl interpreter or NULL */
- Tcl_Obj* objPtr; /* Pointer to the object to parse */
+ Tcl_Interp *interp; /* Tcl interpreter or NULL */
+ Tcl_Obj* objPtr; /* Pointer to the object to parse */
{
int offset; /* Offset in the "end-offset" expression */
register char* bytes; /* String rep of the object */
int length; /* Length of the object's string rep */
- /* If it's already the right type, we're fine. */
+ /*
+ * If it's already the right type, we're fine.
+ */
if (objPtr->typePtr == &tclEndOffsetType) {
return TCL_OK;
}
- /* Check for a string rep of the right form. */
+ /*
+ * Check for a string rep of the right form.
+ */
bytes = Tcl_GetStringFromObj(objPtr, &length);
if ((*bytes != 'e') || (strncmp(bytes, "end",
@@ -2449,15 +2447,18 @@ SetEndOffsetFromAny(interp, objPtr)
return TCL_ERROR;
}
- /* Convert the string rep */
+ /*
+ * Convert the string rep.
+ */
if (length <= 3) {
offset = 0;
} else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) {
/*
- * This is our limited string expression evaluator. Pass everything
+ * This is our limited string expression evaluator. Pass everything
* after "end-" to Tcl_GetInt, then reverse for offset.
*/
+
if (isspace(UCHAR(bytes[4]))) {
return TCL_ERROR;
}
@@ -2469,8 +2470,9 @@ SetEndOffsetFromAny(interp, objPtr)
}
} else {
/*
- * Conversion failed. Report the error.
+ * Conversion failed. Report the error.
*/
+
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad index \"", bytes,
@@ -2480,8 +2482,8 @@ SetEndOffsetFromAny(interp, objPtr)
}
/*
- * The conversion succeeded. Free the old internal rep and set
- * the new one.
+ * The conversion succeeded. Free the old internal rep and set the new
+ * one.
*/
TclFreeIntRep(objPtr);
@@ -2489,15 +2491,15 @@ SetEndOffsetFromAny(interp, objPtr)
objPtr->typePtr = &tclEndOffsetType;
return TCL_OK;
-}
+}
/*
*----------------------------------------------------------------------
*
* TclCheckBadOctal --
*
- * This procedure checks for a bad octal value and appends a
- * meaningful error to the interp's result.
+ * This function checks for a bad octal value and appends a meaningful
+ * error to the interp's result.
*
* Results:
* 1 if the argument was a bad octal, else 0.
@@ -2510,16 +2512,16 @@ SetEndOffsetFromAny(interp, objPtr)
int
TclCheckBadOctal(interp, value)
- Tcl_Interp *interp; /* Interpreter to use for error reporting.
- * If NULL, then no error message is left
- * after errors. */
+ Tcl_Interp *interp; /* Interpreter to use for error reporting. If
+ * NULL, then no error message is left after
+ * errors. */
CONST char *value; /* String to check. */
{
register CONST char *p = value;
/*
- * A frequent mistake is invalid octal values due to an unwanted
- * leading zero. Try to generate a meaningful error message.
+ * A frequent mistake is invalid octal values due to an unwanted leading
+ * zero. Try to generate a meaningful error message.
*/
while (isspace(UCHAR(*p))) { /* INTL: ISO space. */
@@ -2536,11 +2538,14 @@ TclCheckBadOctal(interp, value)
p++;
}
if (*p == '\0') {
- /* Reached end of string */
+ /*
+ * Reached end of string.
+ */
+
if (interp != NULL) {
/*
- * Don't reset the result here because we want this result
- * to be added to an existing error message as extra info.
+ * Don't reset the result here because we want this result to
+ * be added to an existing error message as extra info.
*/
Tcl_AppendResult(interp, " (looks like invalid octal number)",
(char *) NULL);
@@ -2555,6 +2560,7 @@ TclCheckBadOctal(interp, value)
*----------------------------------------------------------------------
*
* ClearHash --
+ *
* Remove all the entries in the hash table *tablePtr.
*
*----------------------------------------------------------------------
@@ -2580,16 +2586,15 @@ ClearHash(tablePtr)
*
* GetThreadHash --
*
- * Get a thread-specific (Tcl_HashTable *) associated with a
- * thread data key.
+ * Get a thread-specific (Tcl_HashTable *) associated with a thread data
+ * key.
*
* Results:
- * The Tcl_HashTable * corresponding to *keyPtr.
+ * The Tcl_HashTable * corresponding to *keyPtr.
*
* Side effects:
- * The first call on a keyPtr in each thread creates a new
- * Tcl_HashTable, and registers a thread exit handler to
- * dispose of it.
+ * The first call on a keyPtr in each thread creates a new Tcl_HashTable,
+ * and registers a thread exit handler to dispose of it.
*
*----------------------------------------------------------------------
*/
@@ -2612,8 +2617,9 @@ GetThreadHash(keyPtr)
*----------------------------------------------------------------------
*
* FreeThreadHash --
- * Thread exit handler used by GetThreadHash to dispose
- * of a thread hash table.
+ *
+ * Thread exit handler used by GetThreadHash to dispose of a thread hash
+ * table.
*
* Side effects:
* Frees a Tcl_HashTable.
@@ -2623,7 +2629,7 @@ GetThreadHash(keyPtr)
static void
FreeThreadHash(clientData)
- ClientData clientData;
+ ClientData clientData;
{
Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData;
ClearHash(tablePtr);
@@ -2635,15 +2641,16 @@ FreeThreadHash(clientData)
*----------------------------------------------------------------------
*
* FreeProcessGlobalValue --
- * Exit handler used by Tcl(Set|Get)ProcessGlobalValue to cleanup
- * a ProcessGlobalValue at exit.
+ *
+ * Exit handler used by Tcl(Set|Get)ProcessGlobalValue to cleanup a
+ * ProcessGlobalValue at exit.
*
*----------------------------------------------------------------------
*/
static void
FreeProcessGlobalValue(clientData)
- ClientData clientData;
+ ClientData clientData;
{
ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *) clientData;
pgvPtr->epoch++;
@@ -2662,11 +2669,12 @@ FreeProcessGlobalValue(clientData)
*
* TclSetProcessGlobalValue --
*
- * Utility routine to set a global value shared by all threads in
- * the process while keeping a thread-local copy as well.
+ * Utility routine to set a global value shared by all threads in the
+ * process while keeping a thread-local copy as well.
*
*----------------------------------------------------------------------
*/
+
void
TclSetProcessGlobalValue(pgvPtr, newValue, encoding)
ProcessGlobalValue *pgvPtr;
@@ -2679,7 +2687,11 @@ TclSetProcessGlobalValue(pgvPtr, newValue, encoding)
int dummy;
Tcl_MutexLock(&pgvPtr->mutex);
- /* Fill the global string value */
+
+ /*
+ * Fill the global string value.
+ */
+
pgvPtr->epoch++;
if (NULL != pgvPtr->value) {
ckfree(pgvPtr->value);
@@ -2695,10 +2707,11 @@ TclSetProcessGlobalValue(pgvPtr, newValue, encoding)
pgvPtr->encoding = encoding;
/*
- * Fill the local thread copy directly with the Tcl_Obj
- * value to avoid loss of the intrep. Increment newValue
- * refCount early to handle case where we set a PGV to itself.
+ * Fill the local thread copy directly with the Tcl_Obj value to avoid
+ * loss of the intrep. Increment newValue refCount early to handle case
+ * where we set a PGV to itself.
*/
+
Tcl_IncrRefCount(newValue);
cacheMap = GetThreadHash(&pgvPtr->key);
ClearHash(cacheMap);
@@ -2732,12 +2745,12 @@ TclGetProcessGlobalValue(pgvPtr)
if (pgvPtr->encoding) {
Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);
- if (pgvPtr->encoding != current) {
+ if (pgvPtr->encoding != current) {
/*
- * The system encoding has changed since the master
- * string value was saved. Convert the master value
- * to be based on the new system encoding.
+ * The system encoding has changed since the master string value
+ * was saved. Convert the master value to be based on the new
+ * system encoding.
*/
Tcl_DString native, newValue;
@@ -2753,7 +2766,7 @@ TclGetProcessGlobalValue(pgvPtr)
ckfree(pgvPtr->value);
pgvPtr->value = ckalloc((unsigned int)
Tcl_DStringLength(&newValue) + 1);
- memcpy((VOID *) pgvPtr->value, (VOID *) Tcl_DStringValue(&newValue),
+ memcpy((VOID*) pgvPtr->value, (VOID*) Tcl_DStringValue(&newValue),
(size_t) Tcl_DStringLength(&newValue) + 1);
Tcl_DStringFree(&newValue);
Tcl_FreeEncoding(pgvPtr->encoding);
@@ -2768,12 +2781,19 @@ TclGetProcessGlobalValue(pgvPtr)
if (NULL == hPtr) {
int dummy;
- /* No cache for the current epoch - must be a new one */
- /* First, clear the cacheMap, as anything in it must
- * refer to some expired epoch.*/
+ /*
+ * No cache for the current epoch - must be a new one.
+ *
+ * First, clear the cacheMap, as anything in it must refer to some
+ * expired epoch.
+ */
+
ClearHash(cacheMap);
- /* If no thread has set the shared value, call the initializer */
+ /*
+ * If no thread has set the shared value, call the initializer.
+ */
+
Tcl_MutexLock(&pgvPtr->mutex);
if ((NULL == pgvPtr->value) && (pgvPtr->proc)) {
pgvPtr->epoch++;
@@ -2785,7 +2805,10 @@ TclGetProcessGlobalValue(pgvPtr)
Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr);
}
- /* Store a copy of the shared value in our epoch-indexed cache */
+ /*
+ * Store a copy of the shared value in our epoch-indexed cache.
+ */
+
value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes);
hPtr = Tcl_CreateHashEntry(cacheMap, (char *)pgvPtr->epoch, &dummy);
Tcl_MutexUnlock(&pgvPtr->mutex);
@@ -2800,9 +2823,8 @@ TclGetProcessGlobalValue(pgvPtr)
*
* TclSetObjNameOfExecutable --
*
- * This procedure stores the absolute pathname of
- * the executable file (normally as computed by
- * TclpFindExecutable).
+ * This function stores the absolute pathname of the executable file
+ * (normally as computed by TclpFindExecutable).
*
* Results:
* None.
@@ -2826,15 +2848,14 @@ TclSetObjNameOfExecutable(name, encoding)
*
* TclGetObjNameOfExecutable --
*
- * This procedure retrieves the absolute pathname of the
- * application in which the Tcl library is running, usually
- * as previously stored by TclpFindExecutable().
- * This procedure call is the C API equivalent to the
- * "info nameofexecutable" command.
+ * This function retrieves the absolute pathname of the application in
+ * which the Tcl library is running, usually as previously stored by
+ * TclpFindExecutable(). This function call is the C API equivalent to
+ * the "info nameofexecutable" command.
*
* Results:
- * A pointer to an "fsPath" Tcl_Obj, or to an empty Tcl_Obj if
- * the pathname of the application is unknown.
+ * A pointer to an "fsPath" Tcl_Obj, or to an empty Tcl_Obj if the
+ * pathname of the application is unknown.
*
* Side effects:
* None.
@@ -2853,17 +2874,15 @@ TclGetObjNameOfExecutable()
*
* Tcl_GetNameOfExecutable --
*
- * This procedure retrieves the absolute pathname of the
- * application in which the Tcl library is running, and
- * returns it in string form.
+ * This function retrieves the absolute pathname of the application in
+ * which the Tcl library is running, and returns it in string form.
*
- * The returned string belongs to Tcl and should be copied
- * if the caller plans to keep it, to guard against it
- * becoming invalid.
+ * The returned string belongs to Tcl and should be copied if the caller
+ * plans to keep it, to guard against it becoming invalid.
*
* Results:
- * A pointer to the internal string or NULL if the internal full
- * path name has not been computed or unknown.
+ * A pointer to the internal string or NULL if the internal full path
+ * name has not been computed or unknown.
*
* Side effects:
* None.
@@ -2888,7 +2907,9 @@ Tcl_GetNameOfExecutable()
*
* TclpGetTime --
*
- * Deprecated synonym for Tcl_GetTime.
+ * Deprecated synonym for Tcl_GetTime. This function is provided for the
+ * benefit of extensions written before Tcl_GetTime was exported from the
+ * library.
*
* Results:
* None.
@@ -2896,9 +2917,6 @@ Tcl_GetNameOfExecutable()
* Side effects:
* Stores current time in the buffer designated by "timePtr"
*
- * This procedure is provided for the benefit of extensions written
- * before Tcl_GetTime was exported from the library.
- *
*----------------------------------------------------------------------
*/
@@ -2914,14 +2932,14 @@ TclpGetTime(timePtr)
*
* TclGetPlatform --
*
- * This is a kludge that allows the test library to get access
- * the internal tclPlatform variable.
+ * This is a kludge that allows the test library to get access the
+ * internal tclPlatform variable.
*
* Results:
- * Returns a pointer to the tclPlatform variable.
+ * Returns a pointer to the tclPlatform variable.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -2931,3 +2949,11 @@ TclGetPlatform()
{
return &tclPlatform;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
generated by cgit v0.12 at 2024-10-31 01:38:01 (GMT)