diff options
45 files changed, 1611 insertions, 1538 deletions
diff --git a/generic/tclAsync.c b/generic/tclAsync.c index 175eaad..208b2fa 100644 --- a/generic/tclAsync.c +++ b/generic/tclAsync.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAsync.c,v 1.17 2008/10/26 18:34:03 dkf Exp $ + * RCS: @(#) $Id: tclAsync.c,v 1.18 2009/01/09 11:21:45 dkf Exp $ */ #include "tclInt.h" @@ -306,7 +306,7 @@ Tcl_AsyncDelete( tsdPtr->firstHandler = asyncPtr->nextPtr; } else { prevPtr->nextPtr = asyncPtr->nextPtr; - } + } if (asyncPtr == tsdPtr->lastHandler) { tsdPtr->lastHandler = prevPtr; } diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5f8d9dc..ab1806e 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.379 2009/01/05 09:48:11 dkf Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.380 2009/01/09 11:21:45 dkf Exp $ */ #include "tclInt.h" @@ -172,6 +172,7 @@ static const CmdInfo builtInCmds[] = { {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, 1}, {"concat", Tcl_ConcatObjCmd, NULL, NULL, 1}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, 1}, + {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, 1}, {"error", Tcl_ErrorObjCmd, NULL, NULL, 1}, {"eval", Tcl_EvalObjCmd, NULL, NULL, 1}, {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, NULL, 1}, @@ -213,9 +214,7 @@ static const CmdInfo builtInCmds[] = { {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1}, {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1}, {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, 1}, - - {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, 1}, - {"yield", NULL, NULL, TclNRYieldObjCmd, 1}, + {"yield", NULL, NULL, TclNRYieldObjCmd, 1}, /* * Commands in the OS-interface. Note that many of these are unsafe. diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 5e86653..6802c10 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBinary.c,v 1.52 2008/12/15 17:11:34 ferrieux Exp $ + * RCS: @(#) $Id: tclBinary.c,v 1.53 2009/01/09 11:21:45 dkf Exp $ */ #include "tclInt.h" @@ -597,8 +597,8 @@ TclInitBinaryCmd( const EnsembleImplMap binaryMap[] = { { "format", BinaryFormatCmd, NULL }, { "scan", BinaryScanCmd, NULL }, - { "encode", NULL, NULL }, - { "decode", NULL, NULL }, + { "encode", NULL, NULL }, + { "decode", NULL, NULL }, { NULL, NULL, NULL } }; const EnsembleImplMap encodeMap[] = { @@ -613,7 +613,6 @@ TclInitBinaryCmd( { "base64", BinaryDecode64, NULL }, { NULL, NULL, NULL } }; - Tcl_Command binaryEnsemble; binaryEnsemble = TclMakeEnsemble(interp, "binary", binaryMap); diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index fd1b2ab..fa7d376 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -14,7 +14,7 @@ * * This code contributed by Karl Lehenbauer and Mark Diekhans * - * RCS: @(#) $Id: tclCkalloc.c,v 1.33 2008/04/27 22:21:29 dkf Exp $ + * RCS: @(#) $Id: tclCkalloc.c,v 1.34 2009/01/09 11:21:45 dkf Exp $ */ #include "tclInt.h" @@ -228,9 +228,9 @@ ValidateMemory( } } if (guard_failed) { - TclDumpMemoryInfo (stderr); + TclDumpMemoryInfo(stderr); fprintf(stderr, "low guard failed at %lx, %s %d\n", - (long unsigned int) memHeaderP->body, file, line); + (long unsigned) memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); @@ -252,7 +252,7 @@ ValidateMemory( if (guard_failed) { TclDumpMemoryInfo(stderr); fprintf(stderr, "high guard failed at %lx, %s %d\n", - (long unsigned int) memHeaderP->body, file, line); + (long unsigned) memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, @@ -336,10 +336,10 @@ Tcl_DumpActiveMemory( Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { - address = &memScanP->body [0]; + address = &memScanP->body[0]; fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", - (long unsigned int) address, - (long unsigned int) address + memScanP->length - 1, + (long unsigned) address, + (long unsigned) address + memScanP->length - 1, memScanP->length, memScanP->file, memScanP->line, (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); @@ -824,7 +824,7 @@ MemoryCmd( if (fileName == NULL) { return TCL_ERROR; } - result = Tcl_DumpActiveMemory (fileName); + result = Tcl_DumpActiveMemory(fileName); Tcl_DStringFree(&buffer); if (result != TCL_OK) { Tcl_AppendResult(interp, "error accessing ", argv[2], NULL); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index cd82228..8dc4c12 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.163 2008/10/17 16:32:58 dgp Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.164 2009/01/09 11:21:45 dkf Exp $ */ #include "tclInt.h" @@ -35,7 +35,7 @@ typedef struct SortElement { double doubleValue; Tcl_Obj *objValuePtr; } index; - Tcl_Obj *objPtr; /* Object being sorted, or its index. */ + Tcl_Obj *objPtr; /* Object being sorted, or its index. */ struct SortElement *nextPtr;/* Next element in the list, or NULL for end * of list. */ } SortElement; @@ -160,7 +160,7 @@ static const EnsembleImplMap defaultInfoMap[] = { {"cmdcount", InfoCmdCountCmd, NULL}, {"commands", InfoCommandsCmd, NULL}, {"complete", InfoCompleteCmd, NULL}, - {"coroutine", TclInfoCoroutineCmd, NULL}, + {"coroutine", TclInfoCoroutineCmd, NULL}, {"default", InfoDefaultCmd, NULL}, {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd}, {"frame", InfoFrameCmd, NULL}, @@ -1058,7 +1058,7 @@ InfoFrameCmd( */ topLevel += iPtr->execEnvPtr->corPtr->caller.cmdFramePtr->level + 1 - - iPtr->execEnvPtr->corPtr->base.cmdFramePtr->level; + iPtr->execEnvPtr->corPtr->base.cmdFramePtr->level; } if (objc == 1) { @@ -1066,7 +1066,7 @@ InfoFrameCmd( * Just "info frame". */ - Tcl_SetObjResult(interp, Tcl_NewIntObj (topLevel)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel)); return TCL_OK; } else if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "?number?"); @@ -3823,7 +3823,7 @@ Tcl_LsortObjCmd( * begins sorting it into the sublists as it appears. */ - elementArray = (SortElement *) ckalloc( length * sizeof(SortElement)); + elementArray = (SortElement *) ckalloc(length * sizeof(SortElement)); for (i=0; i < length; i++){ idx = groupSize * i + groupOffset; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index feb87cd..f5f6547 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.174 2009/01/05 11:27:41 dkf Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.175 2009/01/09 11:21:45 dkf Exp $ */ #include "tclInt.h" @@ -3824,7 +3824,7 @@ Tcl_SwitchObjCmd( if (ctxPtr->type == TCL_LOCATION_BC) { /* * Type BC => ctxPtr->data.eval.path is not used. - * ctxPtr->data.tebc.codePtr is used instead. + * ctxPtr->data.tebc.codePtr is used instead. */ TclGetSrcInfoForPc(ctxPtr); diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 74dceac..5d8e31a 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.150 2008/11/19 00:00:20 ferrieux Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.151 2009/01/09 11:21:45 dkf Exp $ */ #include "tclInt.h" @@ -31,7 +31,7 @@ TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ (tokenPtr)[1].size), (envPtr)); \ } else { \ - envPtr->line = mapPtr->loc[eclIndex].line[word]; \ + envPtr->line = mapPtr->loc[eclIndex].line[word]; \ TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ (envPtr)); \ } @@ -71,7 +71,7 @@ #define CompileTokens(envPtr, tokenPtr, interp) \ TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)); + (envPtr)); /* * Convenience macro for use when pushing literals. The ANSI C "prototype" for * this macro is: @@ -4911,7 +4911,7 @@ PushVarName( int *localIndexPtr, /* Must not be NULL. */ int *simpleVarNamePtr, /* Must not be NULL. */ int *isScalarPtr, /* Must not be NULL. */ - int line) /* Line the token starts on. */ + int line) /* Line the token starts on. */ { register const char *p; const char *name, *elName; @@ -5705,7 +5705,7 @@ TclCompileDivOpCmd( * * Results: * Returns the variable's index in the table of compiled locals if the - * tail is known at compile time, or -1 otherwise. + * tail is known at compile time, or -1 otherwise. * * Side effects: * None. @@ -5914,7 +5914,7 @@ TclCompileUpvarCmd( * * Side effects: * Instructions are added to envPtr to execute the "namespace upvar" - * command at runtime. + * command at runtime. * *---------------------------------------------------------------------- */ diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 9c1ee74..48f3cc1 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -1,8 +1,8 @@ /* * tclCompExpr.c -- * - * This file contains the code to parse and compile Tcl expressions - * and implementations of the Tcl commands corresponding to expression + * This file contains the code to parse and compile Tcl expressions and + * implementations of the Tcl commands corresponding to expression * operators, such as the command ::tcl::mathop::+ . * * Contributions from Don Porter, NIST, 2006-2007. (not subject to US copyright) @@ -10,18 +10,18 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompExpr.c,v 1.98 2008/10/26 18:34:04 dkf Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.99 2009/01/09 11:21:45 dkf Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* CompileEnv */ /* - * Expression parsing takes place in the routine ParseExpr(). It takes a - * string as input, parses that string, and generates a representation of - * the expression in the form of a tree of operators, a list of literals, - * a list of function names, and an array of Tcl_Token's within a Tcl_Parse - * struct. The tree is composed of OpNodes. + * Expression parsing takes place in the routine ParseExpr(). It takes a + * string as input, parses that string, and generates a representation of the + * expression in the form of a tree of operators, a list of literals, a list + * of function names, and an array of Tcl_Token's within a Tcl_Parse struct. + * The tree is composed of OpNodes. */ typedef struct OpNode { @@ -38,36 +38,36 @@ typedef struct OpNode { } OpNode; /* - * The storage for the tree is dynamically allocated array of OpNodes. The + * The storage for the tree is dynamically allocated array of OpNodes. The * array is grown as parsing needs dictate according to a scheme similar to * Tcl's string growth algorithm, so that the resizing costs are O(N) and so * that we use at least half the memory allocated as expressions get large. * * Each OpNode in the tree represents an operator in the expression, either - * unary or binary. When parsing is completed successfully, a binary operator + * unary or binary. When parsing is completed successfully, a binary operator * OpNode will have its left and right fields filled with "pointers" to its - * left and right operands. A unary operator OpNode will have its right field - * filled with a pointer to its single operand. When an operand is a + * left and right operands. A unary operator OpNode will have its right field + * filled with a pointer to its single operand. When an operand is a * subexpression the "pointer" takes the form of the index -- a non-negative * integer -- into the OpNode storage array where the root of that - * subexpression parse tree is found. + * subexpression parse tree is found. * * Non-operator elements of the expression do not get stored in the OpNode - * tree. They are stored in the other structures according to their type. - * Literal values get appended to the literal list. Elements that denote - * forms of quoting or substitution known to the Tcl parser get stored as - * Tcl_Tokens. These non-operator elements of the expression are the - * leaves of the completed parse tree. When an operand of an OpNode is - * one of these leaf elements, the following negative integer codes are used - * to indicate which kind of elements it is. + * tree. They are stored in the other structures according to their type. + * Literal values get appended to the literal list. Elements that denote forms + * of quoting or substitution known to the Tcl parser get stored as + * Tcl_Tokens. These non-operator elements of the expression are the leaves of + * the completed parse tree. When an operand of an OpNode is one of these leaf + * elements, the following negative integer codes are used to indicate which + * kind of elements it is. */ enum OperandTypes { OT_LITERAL = -3, /* Operand is a literal in the literal list */ OT_TOKENS = -2, /* Operand is sequence of Tcl_Tokens */ - OT_EMPTY = -1 /* "Operand" is an empty string. This is a - * special case used only to represent the - * EMPTY lexeme. See below. */ + OT_EMPTY = -1 /* "Operand" is an empty string. This is a special + * case used only to represent the EMPTY lexeme. See + * below. */ }; /* @@ -81,31 +81,30 @@ enum OperandTypes { /* * Note that it is sufficient to store in the tree just the type of leaf - * operand, without any explicit pointer to which leaf. This is true because - * the traversals of the completed tree we perform are known to visit - * the leaves in the same order as the original parse. + * operand, without any explicit pointer to which leaf. This is true because + * the traversals of the completed tree we perform are known to visit the + * leaves in the same order as the original parse. * * In a completed parse tree, those OpNodes that are themselves (roots of * subexpression trees that are) operands of some operator store in their - * p.parent field a "pointer" to the OpNode of that operator. The p.parent - * field permits a traversal of the tree within a * non-recursive routine - * (ConvertTreeToTokens() and CompileExprTree()). This means that even + * p.parent field a "pointer" to the OpNode of that operator. The p.parent + * field permits a traversal of the tree within a non-recursive routine + * (ConvertTreeToTokens() and CompileExprTree()). This means that even * expression trees of great depth pose no risk of blowing the C stack. * - * While the parse tree is being constructed, the same memory space is used - * to hold the p.prev field which chains together a stack of incomplete - * trees awaiting their right operands. + * While the parse tree is being constructed, the same memory space is used to + * hold the p.prev field which chains together a stack of incomplete trees + * awaiting their right operands. * * The lexeme field is filled in with the lexeme of the operator that is - * returned by the ParseLexeme() routine. Only lexemes for unary and - * binary operators get stored in an OpNode. Other lexmes get different - * treatement. + * returned by the ParseLexeme() routine. Only lexemes for unary and binary + * operators get stored in an OpNode. Other lexmes get different treatement. * * The precedence field provides a place to store the precedence of the * operator, so it need not be looked up again and again. * - * The mark field is use to control the traversal of the tree, so - * that it can be done non-recursively. The mark values are: + * The mark field is use to control the traversal of the tree, so that it can + * be done non-recursively. The mark values are: */ enum Marks { @@ -121,52 +120,51 @@ enum Marks { */ /* - * Each lexeme belongs to one of four categories, which determine - * its place in the parse tree. We use the two high bits of the - * (unsigned char) value to store a NODE_TYPE code. + * Each lexeme belongs to one of four categories, which determine its place in + * the parse tree. We use the two high bits of the (unsigned char) value to + * store a NODE_TYPE code. */ #define NODE_TYPE 0xC0 /* - * The four category values are LEAF, UNARY, and BINARY, explained below, - * and "uncategorized", which is used either temporarily, until context - * determines which of the other three categories is correct, or for - * lexemes like INVALID, which aren't really lexemes at all, but indicators - * of a parsing error. Note that the codes must be distinct to distinguish - * categories, but need not take the form of a bit array. + * The four category values are LEAF, UNARY, and BINARY, explained below, and + * "uncategorized", which is used either temporarily, until context determines + * which of the other three categories is correct, or for lexemes like + * INVALID, which aren't really lexemes at all, but indicators of a parsing + * error. Note that the codes must be distinct to distinguish categories, but + * need not take the form of a bit array. */ -#define BINARY 0x40 /* This lexeme is a binary operator. An - * OpNode representing it should go into the - * parse tree, and two operands should be - * parsed for it in the expression. */ -#define UNARY 0x80 /* This lexeme is a unary operator. An OpNode +#define BINARY 0x40 /* This lexeme is a binary operator. An OpNode + * representing it should go into the parse + * tree, and two operands should be parsed for + * it in the expression. */ +#define UNARY 0x80 /* This lexeme is a unary operator. An OpNode * representing it should go into the parse * tree, and one operand should be parsed for * it in the expression. */ #define LEAF 0xC0 /* This lexeme is a leaf operand in the parse - * tree. No OpNode will be placed in the tree - * for it. Either a literal value will be + * tree. No OpNode will be placed in the tree + * for it. Either a literal value will be * appended to the list of literals in this * expression, or appropriate Tcl_Tokens will - * be appended in a Tcl_Parse struct to + * be appended in a Tcl_Parse struct to * represent those leaves that require some - * form of substitution. - */ + * form of substitution. */ /* Uncategorized lexemes */ -#define PLUS 1 /* Ambiguous. Resolves to UNARY_PLUS or +#define PLUS 1 /* Ambiguous. Resolves to UNARY_PLUS or * BINARY_PLUS according to context. */ -#define MINUS 2 /* Ambiguous. Resolves to UNARY_MINUS or +#define MINUS 2 /* Ambiguous. Resolves to UNARY_MINUS or * BINARY_MINUS according to context. */ -#define BAREWORD 3 /* Ambigous. Resolves to BOOLEAN or to +#define BAREWORD 3 /* Ambigous. Resolves to BOOLEAN or to * FUNCTION or a parse error according to * context and value. */ -#define INCOMPLETE 4 /* A parse error. Used only when the single +#define INCOMPLETE 4 /* A parse error. Used only when the single * "=" is encountered. */ -#define INVALID 5 /* A parse error. Used when any punctuation +#define INVALID 5 /* A parse error. Used when any punctuation * appears that's not a supported operator. */ /* Leaf lexemes */ @@ -178,9 +176,9 @@ enum Marks { #define VARIABLE ( LEAF | 5) /* Variable substitution; $x */ #define QUOTED ( LEAF | 6) /* Quoted string; "foo $bar [soom]" */ #define EMPTY ( LEAF | 7) /* Used only for an empty argument - * list to a function. Represents - * the empty string within parens in - * the expression: rand() */ + * list to a function. Represents the + * empty string within parens in the + * expression: rand() */ /* Unary operator lexemes */ @@ -188,28 +186,29 @@ enum Marks { #define UNARY_MINUS ( UNARY | MINUS) #define FUNCTION ( UNARY | BAREWORD) /* This is a bit of "creative * interpretation" on the part of the - * parser. A function call is parsed + * parser. A function call is parsed * into the parse tree according to * the perspective that the function * name is a unary operator and its * argument list, enclosed in parens, - * is its operand. The additional + * is its operand. The additional * requirements not implied generally * by treatment as a unary operator -- * for example, the requirement that - * the operand be enclosed in parens -- - * are hard coded in the relevant - * portions of ParseExpr(). We trade + * the operand be enclosed in parens + * -- are hard coded in the relevant + * portions of ParseExpr(). We trade * off the need to include such * exceptional handling in the code * against the need we would otherwise * have for more lexeme categories. */ #define START ( UNARY | 4) /* This lexeme isn't parsed from the - * expression text at all. It + * expression text at all. It * represents the start of the * expression and sits at the root of * the parse tree where it serves as - * the start/end point of traversals. */ + * the start/end point of + * traversals. */ #define OPEN_PAREN ( UNARY | 5) /* Another bit of creative * interpretation, where we treat "(" * as a unary operator with the @@ -223,14 +222,15 @@ enum Marks { #define BINARY_PLUS ( BINARY | PLUS) #define BINARY_MINUS ( BINARY | MINUS) -#define COMMA ( BINARY | 3) /* The "," operator is a low precedence - * binary operator that separates the - * arguments in a function call. The - * additional constraint that this - * operator can only legally appear - * at the right places within a - * function call argument list are - * hard coded within ParseExpr(). */ +#define COMMA ( BINARY | 3) /* The "," operator is a low + * precedence binary operator that + * separates the arguments in a + * function call. The additional + * constraint that this operator can + * only legally appear at the right + * places within a function call + * argument list are hard coded within + * ParseExpr(). */ #define MULT ( BINARY | 4) #define DIVIDE ( BINARY | 5) #define MOD ( BINARY | 6) @@ -241,14 +241,13 @@ enum Marks { #define BIT_OR ( BINARY | 11) #define QUESTION ( BINARY | 12) /* These two lexemes make up the */ #define COLON ( BINARY | 13) /* ternary conditional operator, - * $x ? $y : $z . We treat them as - * two binary operators to avoid - * another lexeme category, and - * code the additional constraints - * directly in ParseExpr(). For - * instance, the right operand of - * a "?" operator must be a ":" - * operator. */ + * $x ? $y : $z . We treat them as two + * binary operators to avoid another + * lexeme category, and code the + * additional constraints directly in + * ParseExpr(). For instance, the + * right operand of a "?" operator + * must be a ":" operator. */ #define LEFT_SHIFT ( BINARY | 14) #define RIGHT_SHIFT ( BINARY | 15) #define LEQ ( BINARY | 16) @@ -275,23 +274,22 @@ enum Marks { * operators according to precedence * performs most of the work of * matching open and close parens for - * us. In the end though, a close + * us. In the end though, a close * paren is not really a binary * operator, and some special coding * in ParseExpr() make sure we never - * put an actual CLOSE_PAREN node - * in the parse tree. The - * sub-expression between parens - * becomes the single argument of - * the matching OPEN_PAREN unary - * operator. */ + * put an actual CLOSE_PAREN node in + * the parse tree. The sub-expression + * between parens becomes the single + * argument of the matching OPEN_PAREN + * unary operator. */ #define END ( BINARY | 28) /* This lexeme represents the end of - * the string being parsed. Treating + * the string being parsed. Treating * it as a binary operator follows the - * same logic as the CLOSE_PAREN lexeme - * and END pairs with START, in the - * same way that CLOSE_PAREN pairs with - * OPEN_PAREN. */ + * same logic as the CLOSE_PAREN + * lexeme and END pairs with START, in + * the same way that CLOSE_PAREN pairs + * with OPEN_PAREN. */ /* * When ParseExpr() builds the parse tree it must choose which operands to * connect to which operators. This is done according to operator precedence. @@ -523,7 +521,6 @@ static int ParseExpr(Tcl_Interp *interp, const char *start, Tcl_Parse *parsePtr, int parseOnly); static int ParseLexeme(const char *start, int numBytes, unsigned char *lexemePtr, Tcl_Obj **literalPtr); - /* *---------------------------------------------------------------------- @@ -531,27 +528,27 @@ static int ParseLexeme(const char *start, int numBytes, * ParseExpr -- * * Given a string, the numBytes bytes starting at start, this function - * parses it as a Tcl expression and constructs a tree representing - * the structure of the expression. The caller must pass in empty - * lists as the funcList and litList arguments. The elements of the - * parsed expression are returned to the caller as that tree, a list of - * literal values, a list of function names, and in Tcl_Tokens - * added to a Tcl_Parse struct passed in by the caller. + * parses it as a Tcl expression and constructs a tree representing the + * structure of the expression. The caller must pass in empty lists as + * the funcList and litList arguments. The elements of the parsed + * expression are returned to the caller as that tree, a list of literal + * values, a list of function names, and in Tcl_Tokens added to a + * Tcl_Parse struct passed in by the caller. * * Results: * If the string is successfully parsed as a valid Tcl expression, TCL_OK - * is returned, and data about the expression structure is written to - * the last four arguments. If the string cannot be parsed as a valid - * Tcl expression, TCL_ERROR is returned, and if interp is non-NULL, an - * error message is written to interp. + * is returned, and data about the expression structure is written to the + * last four arguments. If the string cannot be parsed as a valid Tcl + * expression, TCL_ERROR is returned, and if interp is non-NULL, an error + * message is written to interp. * * Side effects: - * Memory will be allocated. If TCL_OK is returned, the caller must - * clean up the returned data structures. The (OpNode *) value written - * to opTreePtr should be passed to ckfree() and the parsePtr argument - * should be passed to Tcl_FreeParse(). The elements appended to the - * litList and funcList will automatically be freed whenever the - * refcount on those lists indicates they can be freed. + * Memory will be allocated. If TCL_OK is returned, the caller must clean + * up the returned data structures. The (OpNode *) value written to + * opTreePtr should be passed to ckfree() and the parsePtr argument + * should be passed to Tcl_FreeParse(). The elements appended to the + * litList and funcList will automatically be freed whenever the refcount + * on those lists indicates they can be freed. * *---------------------------------------------------------------------- */ @@ -570,38 +567,39 @@ ParseExpr( * substitutions. */ int parseOnly) /* A boolean indicating whether the caller's * aim is just a parse, or whether it will go - * on to compile the expression. Different - * optimizations are appropriate for the - * two scenarios. */ + * on to compile the expression. Different + * optimizations are appropriate for the two + * scenarios. */ { OpNode *nodes = NULL; /* Pointer to the OpNode storage array where * we build the parse tree. */ - int nodesAvailable = 64; /* Initial size of the storage array. This - * value establishes a minimum tree memory cost - * of only about 1 kibyte, and is large enough - * for most expressions to parse with no need - * for array growth and reallocation. */ + int nodesAvailable = 64; /* Initial size of the storage array. This + * value establishes a minimum tree memory + * cost of only about 1 kibyte, and is large + * enough for most expressions to parse with + * no need for array growth and + * reallocation. */ int nodesUsed = 0; /* Number of OpNodes filled. */ - int scanned = 0; /* Capture number of byte scanned by - * parsing routines. */ + int scanned = 0; /* Capture number of byte scanned by parsing + * routines. */ int lastParsed; /* Stores info about what the lexeme parsed * the previous pass through the parsing loop - * was. If it was an operator, lastParsed is + * was. If it was an operator, lastParsed is * the index of the OpNode for that operator. * If it was not an operator, lastParsed holds - * an OperandTypes value encoding what we - * need to know about it. */ - int incomplete; /* Index of the most recent incomplete tree - * in the OpNode array. Heads a stack of + * an OperandTypes value encoding what we need + * to know about it. */ + int incomplete; /* Index of the most recent incomplete tree in + * the OpNode array. Heads a stack of * incomplete trees linked by p.prev. */ int complete = OT_EMPTY; /* "Index" of the complete tree (that is, a * complete subexpression) determined at the - * moment. OT_EMPTY is a nonsense value - * used only to silence compiler warnings. - * During a parse, complete will always hold - * an index or an OperandTypes value pointing - * to an actual leaf at the time the complete - * tree is needed. */ + * moment. OT_EMPTY is a nonsense value used + * only to silence compiler warnings. During a + * parse, complete will always hold an index + * or an OperandTypes value pointing to an + * actual leaf at the time the complete tree + * is needed. */ /* These variables control generation of the error message. */ Tcl_Obj *msg = NULL; /* The error message. */ @@ -609,19 +607,19 @@ ParseExpr( * for the error message, supplying more * information after the error msg and * location have been reported. */ - const char *mark = "_@_"; /* In the portion of the complete error message - * where the error location is reported, this - * "mark" substring is inserted into the - * string being parsed to aid in pinpointing - * the location of the syntax error in the - * expression. */ + const char *mark = "_@_"; /* In the portion of the complete error + * message where the error location is + * reported, this "mark" substring is inserted + * into the string being parsed to aid in + * pinpointing the location of the syntax + * error in the expression. */ int insertMark = 0; /* A boolean controlling whether the "mark" * should be inserted. */ const int limit = 25; /* Portions of the error message are * constructed out of substrings of the - * original expression. In order to keep the - * error message readable, we impose this limit - * on the substring size we extract. */ + * original expression. In order to keep the + * error message readable, we impose this + * limit on the substring size we extract. */ TclParseInit(interp, start, numBytes, parsePtr); @@ -631,7 +629,10 @@ ParseExpr( goto error; } - /* Initialize the parse tree with the special "START" node. */ + /* + * Initialize the parse tree with the special "START" node. + */ + nodes->lexeme = START; nodes->precedence = prec[START]; nodes->mark = MARK_RIGHT; @@ -640,25 +641,24 @@ ParseExpr( nodesUsed++; /* - * Main parsing loop parses one lexeme per iteration. We exit the - * loop only when there's a syntax error with a "goto error" which - * takes us to the error handling code following the loop, or when - * we've successfully completed the parse and we return to the caller. + * Main parsing loop parses one lexeme per iteration. We exit the loop + * only when there's a syntax error with a "goto error" which takes us to + * the error handling code following the loop, or when we've successfully + * completed the parse and we return to the caller. */ while (1) { - OpNode *nodePtr; /* Points to the OpNode we may fill this - * pass through the loop. */ + OpNode *nodePtr; /* Points to the OpNode we may fill this pass + * through the loop. */ unsigned char lexeme; /* The lexeme we parse this iteration. */ - Tcl_Obj *literal; /* Filled by the ParseLexeme() call when - * a literal is parsed that has a Tcl_Obj - * rep worth preserving. */ + Tcl_Obj *literal; /* Filled by the ParseLexeme() call when a + * literal is parsed that has a Tcl_Obj rep + * worth preserving. */ const char *lastStart = start - scanned; /* Compute where the lexeme parsed the - * previous pass through the loop began. - * This is helpful for detecting invalid - * octals and providing more complete error - * messages. */ + * previous pass through the loop began. This + * is helpful for detecting invalid octals and + * providing more complete error messages. */ /* * Each pass through this loop adds up to one more OpNode. Allocate @@ -705,11 +705,10 @@ ParseExpr( case BAREWORD: /* - * Most barewords in an expression are a syntax error. - * The exceptions are that when a bareword is followed by - * an open paren, it might be a function call, and when the - * bareword is a legal literal boolean value, we accept that - * as well. + * Most barewords in an expression are a syntax error. The + * exceptions are that when a bareword is followed by an open + * paren, it might be a function call, and when the bareword + * is a legal literal boolean value, we accept that as well. */ if (start[scanned+TclParseAllWhiteSpace( @@ -751,7 +750,8 @@ ParseExpr( && (lastStart[2] >= '0') && (lastStart[2] <= '9')) { const char *end = lastStart + 2; - Tcl_Obj* copy; + Tcl_Obj *copy; + while (isdigit(*end)) { end++; } @@ -775,10 +775,9 @@ ParseExpr( case PLUS: case MINUS: if (IsOperator(lastParsed)) { - /* - * A "+" or "-" coming just after another operator - * must be interpreted as a unary operator. + * A "+" or "-" coming just after another operator must be + * interpreted as a unary operator. */ lexeme |= UNARY; @@ -794,8 +793,8 @@ ParseExpr( /* * Each LEAF results in either a literal getting appended to the * litList, or a sequence of Tcl_Tokens representing a Tcl word - * getting appended to the parsePtr->tokens. No OpNode is filled - * for this lexeme. + * getting appended to the parsePtr->tokens. No OpNode is filled for + * this lexeme. */ case LEAF: { @@ -841,15 +840,16 @@ ParseExpr( * Pro: ~75% memory saving on expressions like * {1+1+1+1+1+.....+1} (Convert "pointer + Tcl_Obj" cost * to "pointer" cost only) - * Con: Cost of the dict store/retrieve on every literal - * in every expression when expressions like the above - * tend to be uncommon. + * Con: Cost of the dict store/retrieve on every literal in + * every expression when expressions like the above tend + * to be uncommon. * The memory savings is temporary; Compiling to bytecode * will collapse things as literals are registered - * anyway, so the savings applies only to the time - * between parsing and compiling. Possibly important - * due to high-water mark nature of memory allocation. + * anyway, so the savings applies only to the time + * between parsing and compiling. Possibly important due + * to high-water mark nature of memory allocation. */ + Tcl_ListObjAppendElement(NULL, litList, literal); complete = lastParsed = OT_LITERAL; start += scanned; @@ -861,8 +861,8 @@ ParseExpr( } /* - * Remaining LEAF cases may involve filling Tcl_Tokens, so - * make room for at least 2 more tokens. + * Remaining LEAF cases may involve filling Tcl_Tokens, so make + * room for at least 2 more tokens. */ TclGrowParseTokenArray(parsePtr, 2); @@ -902,8 +902,8 @@ ParseExpr( break; case SCRIPT: { - Tcl_Parse *nestedPtr = - (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_Parse *nestedPtr = (Tcl_Parse *) + TclStackAlloc(interp, sizeof(Tcl_Parse)); tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; tokenPtr->type = TCL_TOKEN_COMMAND; @@ -947,21 +947,19 @@ ParseExpr( } } if (code != TCL_OK) { - /* - * Here we handle all the syntax errors generated by - * the Tcl_Token generating parsing routines called in the - * switch just above. If the value of parsePtr->incomplete - * is 1, then the error was an unbalanced '[', '(', '{', - * or '"' and parsePtr->term is pointing to that unbalanced - * character. If the value of parsePtr->incomplete is 0, - * then the error is one of lacking whitespace following a - * quoted word, for example: expr {[an error {foo}bar]}, - * and parsePtr->term points to where the whitespace is - * missing. We reset our values of start and scanned so that - * when our error message is constructed, the location of - * the syntax error is sure to appear in it, even if the - * quoted expression is truncated. + * Here we handle all the syntax errors generated by the + * Tcl_Token generating parsing routines called in the switch + * just above. If the value of parsePtr->incomplete is 1, then + * the error was an unbalanced '[', '(', '{', or '"' and + * parsePtr->term is pointing to that unbalanced character. If + * the value of parsePtr->incomplete is 0, then the error is + * one of lacking whitespace following a quoted word, for + * example: expr {[an error {foo}bar]}, and parsePtr->term + * points to where the whitespace is missing. We reset our + * values of start and scanned so that when our error message + * is constructed, the location of the syntax error is sure to + * appear in it, even if the quoted expression is truncated. */ start = parsePtr->term; @@ -973,20 +971,19 @@ ParseExpr( tokenPtr->size = scanned; tokenPtr->numComponents = parsePtr->numTokens - wordIndex - 1; if (!parseOnly && ((lexeme == QUOTED) || (lexeme == BRACED))) { - /* * When this expression is destined to be compiled, and a * braced or quoted word within an expression is known at - * compile time (no runtime substitutions in it), we can - * store it as a literal rather than in its tokenized form. - * This is an advantage since the compiled bytecode is going - * to need the argument in Tcl_Obj form eventually, so it's - * just as well to get there now. Another advantage is that - * with this conversion, larger constant expressions might - * be grown and optimized. + * compile time (no runtime substitutions in it), we can store + * it as a literal rather than in its tokenized form. This is + * an advantage since the compiled bytecode is going to need + * the argument in Tcl_Obj form eventually, so it's just as + * well to get there now. Another advantage is that with this + * conversion, larger constant expressions might be grown and + * optimized. * - * On the contrary, if the end goal of this parse is to - * fill a Tcl_Parse for a caller of Tcl_ParseExpr(), then it's + * On the contrary, if the end goal of this parse is to fill a + * Tcl_Parse for a caller of Tcl_ParseExpr(), then it's * wasteful to convert to a literal only to convert back again * later. */ @@ -1027,16 +1024,16 @@ ParseExpr( /* * A FUNCTION cannot be a constant expression, because Tcl allows * functions to return variable results with the same arguments; - * for example, rand(). Other unary operators can root a constant + * for example, rand(). Other unary operators can root a constant * expression, so long as the argument is a constant expression. */ nodePtr->constant = (lexeme != FUNCTION); /* - * This unary operator is a new incomplete tree, so push it - * onto our stack of incomplete trees. Also remember it as - * the last lexeme we parsed. + * This unary operator is a new incomplete tree, so push it onto + * our stack of incomplete trees. Also remember it as the last + * lexeme we parsed. */ nodePtr->p.prev = incomplete; @@ -1057,15 +1054,14 @@ ParseExpr( if ((lexeme == CLOSE_PAREN) && (nodePtr[-1].lexeme == OPEN_PAREN)) { if (nodePtr[-2].lexeme == FUNCTION) { - /* * Normally, "()" is a syntax error, but as a special * case accept it as an argument list for a function. * Treat this as a special LEAF lexeme, and restart - * the parsing loop with zero characters scanned. - * We'll parse the ")" again the next time through, - * but with the OT_EMPTY leaf as the subexpression - * between the parens. + * the parsing loop with zero characters scanned. We + * will parse the ")" again the next time through, but + * with the OT_EMPTY leaf as the subexpression between + * the parens. */ scanned = 0; @@ -1111,34 +1107,33 @@ ParseExpr( } /* - * Here is where the tree comes together. At this point, we - * have a stack of incomplete trees corresponding to - * substrings that are incomplete expressions, followed by - * a complete tree corresponding to a substring that is itself - * a complete expression, followed by the binary operator we have - * just parsed. The incomplete trees can each be completed by - * adding a right operand. + * Here is where the tree comes together. At this point, we have a + * stack of incomplete trees corresponding to substrings that are + * incomplete expressions, followed by a complete tree + * corresponding to a substring that is itself a complete + * expression, followed by the binary operator we have just + * parsed. The incomplete trees can each be completed by adding a + * right operand. * * To illustrate with an example, when we parse the expression * "1+2*3-4" and we reach this point having just parsed the "-" * operator, we have these incomplete trees: START, "1+", and - * "2*". Next we have the complete subexpression "3". Last is - * the "-" we've just parsed. + * "2*". Next we have the complete subexpression "3". Last is the + * "-" we've just parsed. * - * The next step is to join our complete tree to an operator. - * The choice is governed by the precedence and associativity - * of the competing operators. If we connect it as the right - * operand of our most recent incomplete tree, we get a new - * complete tree, and we can repeat the process. The while - * loop following repeats this until precedence indicates it - * is time to join the complete tree as the left operand of - * the just parsed binary operator. + * The next step is to join our complete tree to an operator. The + * choice is governed by the precedence and associativity of the + * competing operators. If we connect it as the right operand of + * our most recent incomplete tree, we get a new complete tree, + * and we can repeat the process. The while loop following repeats + * this until precedence indicates it is time to join the complete + * tree as the left operand of the just parsed binary operator. * - * Continuing the example, the first pass through the loop - * will join "3" to "2*"; the next pass will join "2*3" to - * "1+". Then we'll exit the loop and join "1+2*3" to "-". - * When we return to parse another lexeme, our stack of - * incomplete trees is START and "1+2*3-". + * Continuing the example, the first pass through the loop will + * join "3" to "2*"; the next pass will join "2*3" to "1+". Then + * we'll exit the loop and join "1+2*3" to "-". When we return to + * parse another lexeme, our stack of incomplete trees is START + * and "1+2*3-". */ while (1) { @@ -1149,16 +1144,18 @@ ParseExpr( } if (incompletePtr->precedence == precedence) { + /* + * Right association rules for exponentiation. + */ - /* Right association rules for exponentiation. */ if (lexeme == EXPON) { break; } /* - * Special association rules for the conditional operators. - * The "?" and ":" operators have equal precedence, but - * must be linked up in sensible pairs. + * Special association rules for the conditional + * operators. The "?" and ":" operators have equal + * precedence, but must be linked up in sensible pairs. */ if ((incompletePtr->lexeme == QUESTION) @@ -1172,7 +1169,9 @@ ParseExpr( } } - /* Some special syntax checks... */ + /* + * Some special syntax checks... + */ /* Parens must balance */ if ((incompletePtr->lexeme == OPEN_PAREN) @@ -1219,9 +1218,9 @@ ParseExpr( } /* - * The QUESTION/COLON and FUNCTION/OPEN_PAREN combinations each - * make up a single operator. Force them to agree whether they - * have a constant expression. + * The QUESTION/COLON and FUNCTION/OPEN_PAREN combinations + * each make up a single operator. Force them to agree whether + * they have a constant expression. */ if ((incompletePtr->lexeme == QUESTION) @@ -1230,7 +1229,6 @@ ParseExpr( } if (incompletePtr->lexeme == START) { - /* * Completing the START tree indicates we're done. * Transfer the parse tree to the caller and return. @@ -1242,8 +1240,8 @@ ParseExpr( /* * With a right operand attached, last incomplete tree has - * become the complete tree. Pop it from the incomplete - * tree stack. + * become the complete tree. Pop it from the incomplete tree + * stack. */ complete = incomplete; @@ -1255,7 +1253,9 @@ ParseExpr( } } - /* More syntax checks... */ + /* + * More syntax checks... + */ /* Parens must balance. */ if (lexeme == CLOSE_PAREN) { @@ -1282,12 +1282,18 @@ ParseExpr( goto error; } - /* Create no node for a CLOSE_PAREN lexeme. */ + /* + * Create no node for a CLOSE_PAREN lexeme. + */ + if (lexeme == CLOSE_PAREN) { break; } - /* Link complete tree as left operand of new node. */ + /* + * Link complete tree as left operand of new node. + */ + nodePtr->lexeme = lexeme; nodePtr->precedence = precedence; nodePtr->mark = MARK_LEFT; @@ -1295,9 +1301,9 @@ ParseExpr( /* * The COMMA operator cannot be optimized, since the function - * needs all of its arguments, and optimization would reduce - * the number. Other binary operators root constant expressions - * when both arguments are constant expressions. + * needs all of its arguments, and optimization would reduce the + * number. Other binary operators root constant expressions when + * both arguments are constant expressions. */ nodePtr->constant = (lexeme != COMMA); @@ -1312,9 +1318,9 @@ ParseExpr( } /* - * With a left operand attached and a right operand missing, - * the just-parsed binary operator is root of a new incomplete - * tree. Push it onto the stack of incomplete trees. + * With a left operand attached and a right operand missing, the + * just-parsed binary operator is root of a new incomplete tree. + * Push it onto the stack of incomplete trees. */ nodePtr->p.prev = incomplete; @@ -1332,31 +1338,35 @@ ParseExpr( error: /* - * We only get here if there's been an error. - * Any errors that didn't get a suitable parsePtr->errorType, - * get recorded as syntax errors. + * We only get here if there's been an error. Any errors that didn't get a + * suitable parsePtr->errorType, get recorded as syntax errors. */ if (parsePtr->errorType == TCL_PARSE_SUCCESS) { parsePtr->errorType = TCL_PARSE_SYNTAX; } - /* Free any partial parse tree we've built. */ + /* + * Free any partial parse tree we've built. + */ + if (nodes != NULL) { ckfree((char*) nodes); } if (interp == NULL) { + /* + * Nowhere to report an error message, so just free it. + */ - /* Nowhere to report an error message, so just free it */ if (msg) { Tcl_DecrRefCount(msg); } } else { /* - * Construct the complete error message. Start with the simple - * error message, pulled from the interp result if necessary... + * Construct the complete error message. Start with the simple error + * message, pulled from the interp result if necessary... */ if (msg == NULL) { @@ -1381,7 +1391,10 @@ ParseExpr( start + scanned, (start + scanned + limit > parsePtr->end) ? "" : "..."); - /* Next, append any postscript message. */ + /* + * Next, append any postscript message. + */ + if (post != NULL) { Tcl_AppendToObj(msg, ";\n", -1); Tcl_AppendObjToObj(msg, post); @@ -1389,7 +1402,10 @@ ParseExpr( } Tcl_SetObjResult(interp, msg); - /* Finally, place context information in the errorInfo. */ + /* + * Finally, place context information in the errorInfo. + */ + numBytes = parsePtr->end - parsePtr->string; Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (parsing expression \"%.*s%s\")", @@ -1408,10 +1424,10 @@ ParseExpr( * Given a string, the numBytes bytes starting at start, and an OpNode * tree and Tcl_Token array created by passing that same string to * ParseExpr(), this function writes into *parsePtr the sequence of - * Tcl_Tokens needed so to satisfy the historical interface provided - * by Tcl_ParseExpr(). Note that this routine exists only for the sake - * of the public Tcl_ParseExpr() routine. It is not used by Tcl itself - * at all. + * Tcl_Tokens needed so to satisfy the historical interface provided by + * Tcl_ParseExpr(). Note that this routine exists only for the sake of + * the public Tcl_ParseExpr() routine. It is not used by Tcl itself at + * all. * * Results: * None. @@ -1447,7 +1463,10 @@ ConvertTreeToTokens( nodePtr->mark++; - /* Handle next child node or leaf */ + /* + * Handle next child node or leaf. + */ + switch (next) { case OT_EMPTY: @@ -1461,7 +1480,10 @@ ConvertTreeToTokens( start +=scanned; numBytes -= scanned; - /* Reparse the literal to get pointers into source string */ + /* + * Reparse the literal to get pointers into source string. + */ + scanned = ParseLexeme(start, numBytes, &lexeme, NULL); TclGrowParseTokenArray(parsePtr, 2); @@ -1481,27 +1503,25 @@ ConvertTreeToTokens( break; case OT_TOKENS: { - /* - * tokenPtr points to a token sequence that came from parsing - * a Tcl word. A Tcl word is made up of a sequence of one or - * more elements. When the word is only a single element, it's - * been the historical practice to replace the TCL_TOKEN_WORD - * token directly with a TCL_TOKEN_SUB_EXPR token. However, - * when the word has multiple elements, a TCL_TOKEN_WORD token - * is kept as a grouping device so that TCL_TOKEN_SUB_EXPR - * always has only one element. Wise or not, these are the - * rules the Tcl expr parser has followed, and for the sake - * of those few callers of Tcl_ParseExpr() we do not change - * them now. Internally, we can do better. + * tokenPtr points to a token sequence that came from parsing a + * Tcl word. A Tcl word is made up of a sequence of one or more + * elements. When the word is only a single element, it's been the + * historical practice to replace the TCL_TOKEN_WORD token + * directly with a TCL_TOKEN_SUB_EXPR token. However, when the + * word has multiple elements, a TCL_TOKEN_WORD token is kept as a + * grouping device so that TCL_TOKEN_SUB_EXPR always has only one + * element. Wise or not, these are the rules the Tcl expr parser + * has followed, and for the sake of those few callers of + * Tcl_ParseExpr() we do not change them now. Internally, we can + * do better. */ int toCopy = tokenPtr->numComponents + 1; if (tokenPtr->numComponents == tokenPtr[1].numComponents + 1) { - /* - * Single element word. Copy tokens and convert the leading + * Single element word. Copy tokens and convert the leading * token to TCL_TOKEN_SUB_EXPR. */ @@ -1512,11 +1532,10 @@ ConvertTreeToTokens( subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR; parsePtr->numTokens += toCopy; } else { - /* - * Multiple element word. Create a TCL_TOKEN_SUB_EXPR - * token to lead, with fields initialized from the leading - * token, then copy entire set of word tokens. + * Multiple element word. Create a TCL_TOKEN_SUB_EXPR token to + * lead, with fields initialized from the leading token, then + * copy entire set of word tokens. */ TclGrowParseTokenArray(parsePtr, toCopy+1); @@ -1542,12 +1561,18 @@ ConvertTreeToTokens( /* Advance to the child node, which is an operator. */ nodePtr = nodes + next; - /* Skip any white space that comes before the subexpression */ + /* + * Skip any white space that comes before the subexpression. + */ + scanned = TclParseAllWhiteSpace(start, numBytes); start +=scanned; numBytes -= scanned; - /* Generate tokens for the operator / subexpression... */ + /* + * Generate tokens for the operator / subexpression... + */ + switch (nodePtr->lexeme) { case OPEN_PAREN: case COMMA: @@ -1564,16 +1589,16 @@ ConvertTreeToTokens( /* * Remember the index of the last subexpression we were - * working on -- that of our parent. We'll stack it later. + * working on -- that of our parent. We'll stack it later. */ parentIdx = subExprTokenIdx; /* * Verify space for the two leading Tcl_Tokens representing - * the subexpression rooted by this operator. The first - * Tcl_Token will be of type TCL_TOKEN_SUB_EXPR; the second - * of type TCL_TOKEN_OPERATOR. + * the subexpression rooted by this operator. The first + * Tcl_Token will be of type TCL_TOKEN_SUB_EXPR; the second of + * type TCL_TOKEN_OPERATOR. */ TclGrowParseTokenArray(parsePtr, 2); @@ -1592,7 +1617,7 @@ ConvertTreeToTokens( /* * Eventually, we know that the numComponents field of the - * Tcl_Token of type TCL_TOKEN_OPERATOR will be 0. This means + * Tcl_Token of type TCL_TOKEN_OPERATOR will be 0. This means * we can make other use of this field for now to track the * stack of subexpressions we have pending. */ @@ -1690,7 +1715,7 @@ ConvertTreeToTokens( /* * All the Tcl_Tokens allocated and filled belong to - * this subexpresion. The first token is the leading + * this subexpresion. The first token is the leading * TCL_TOKEN_SUB_EXPR token, and all the rest (one fewer) * are its components. */ @@ -1711,7 +1736,10 @@ ConvertTreeToTokens( } } - /* Since we're returning to parent, skip child handling code. */ + /* + * Since we're returning to parent, skip child handling code. + */ + nodePtr = nodes + nodePtr->p.parent; goto router; } @@ -1759,16 +1787,16 @@ Tcl_ParseExpr( OpNode *opTree = NULL; /* Will point to the tree of operators */ Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */ Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/ - Tcl_Parse *exprParsePtr = - (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_Parse *exprParsePtr = (Tcl_Parse *) + TclStackAlloc(interp, sizeof(Tcl_Parse)); /* Holds the Tcl_Tokens of substitutions */ if (numBytes < 0) { numBytes = (start ? strlen(start) : 0); } - code = ParseExpr(interp, start, numBytes, &opTree, litList, - funcList, exprParsePtr, 1 /* parseOnly */); + code = ParseExpr(interp, start, numBytes, &opTree, litList, funcList, + exprParsePtr, 1 /* parseOnly */); Tcl_DecrRefCount(funcList); Tcl_DecrRefCount(litList); @@ -1900,11 +1928,10 @@ ParseLexeme( case 'i': if ((numBytes > 1) && (start[1] == 'n') && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) { - /* - * Must make this check so we can tell the difference between - * the "in" operator and the "int" function name and the - * "infinity" numeric value. + * Must make this check so we can tell the difference between the + * "in" operator and the "int" function name and the "infinity" + * numeric value. */ *lexemePtr = IN_LIST; @@ -1950,6 +1977,7 @@ ParseLexeme( scanned = Tcl_UtfToUniChar(start, &ch); } else { char utfBytes[TCL_UTF_MAX]; + memcpy(utfBytes, start, (size_t) numBytes); utfBytes[numBytes] = '\0'; scanned = Tcl_UtfToUniChar(utfBytes, &ch); @@ -1967,6 +1995,7 @@ ParseLexeme( scanned = Tcl_UtfToUniChar(end, &ch); } else { char utfBytes[TCL_UTF_MAX]; + memcpy(utfBytes, end, (size_t) numBytes); utfBytes[numBytes] = '\0'; scanned = Tcl_UtfToUniChar(utfBytes, &ch); @@ -2005,21 +2034,23 @@ TclCompileExpr( const char *script, /* The source script to compile. */ int numBytes, /* Number of bytes in script. */ CompileEnv *envPtr, /* Holds resulting instructions. */ - int optimize) /* 0 for one-off expressions */ + int optimize) /* 0 for one-off expressions. */ { OpNode *opTree = NULL; /* Will point to the tree of operators */ Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */ Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/ - Tcl_Parse *parsePtr = - (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_Parse *parsePtr = (Tcl_Parse *) + TclStackAlloc(interp, sizeof(Tcl_Parse)); /* Holds the Tcl_Tokens of substitutions */ int code = ParseExpr(interp, script, numBytes, &opTree, litList, funcList, parsePtr, 0 /* parseOnly */); if (code == TCL_OK) { + /* + * Valid parse; compile the tree. + */ - /* Valid parse; compile the tree. */ int objc; Tcl_Obj *const *litObjv; Tcl_Obj **funcObjv; @@ -2098,20 +2129,20 @@ ExecConstantExprTree( *---------------------------------------------------------------------- * * CompileExprTree -- - * Compiles and writes to envPtr instructions for the subexpression - * tree at index in the nodes array. (*litObjvPtr) must point to the - * proper location in a corresponding literals list. Likewise, when - * non-NULL, funcObjv and tokenPtr must point into matching arrays of - * function names and Tcl_Token's derived from earlier call to - * ParseExpr(). When optimize is true, any constant subexpressions - * will be precomputed. + * + * Compiles and writes to envPtr instructions for the subexpression tree + * at index in the nodes array. (*litObjvPtr) must point to the proper + * location in a corresponding literals list. Likewise, when non-NULL, + * funcObjv and tokenPtr must point into matching arrays of function + * names and Tcl_Token's derived from earlier call to ParseExpr(). When + * optimize is true, any constant subexpressions will be precomputed. * * Results: * None. * * Side effects: * Adds instructions to envPtr to evaluate the expression at runtime. - * Consumes subtree of nodes rooted at index. Advances the pointer + * Consumes subtree of nodes rooted at index. Advances the pointer * *litObjvPtr. * *---------------------------------------------------------------------- @@ -2187,9 +2218,9 @@ CompileExprTree( /* * Start a count of the number of words in this function - * command invocation. In case there's already a count - * in progress (nested functions), save it in our unused - * "left" field for restoring later. + * command invocation. In case there's already a count in + * progress (nested functions), save it in our unused "left" + * field for restoring later. */ nodePtr->left = numWords; @@ -2227,10 +2258,9 @@ CompileExprTree( /* do nothing */ break; case FUNCTION: - /* - * Use the numWords count we've kept to invoke the - * function command with the correct number of arguments. + * Use the numWords count we've kept to invoke the function + * command with the correct number of arguments. */ if (numWords < 255) { @@ -2239,13 +2269,18 @@ CompileExprTree( TclEmitInstInt4(INST_INVOKE_STK4, numWords, envPtr); } - /* Restore any saved numWords value. */ + /* + * Restore any saved numWords value. + */ + numWords = nodePtr->left; convert = 1; break; case COMMA: + /* + * Each comma implies another function argument. + */ - /* Each comma implies another function argument. */ numWords++; break; case COLON: @@ -2336,10 +2371,10 @@ CompileExprTree( * * However, the design of the "global" and "local" * LiteralTable does not permit the value of lePtr->objPtr - * to change. So rather than replace lePtr->objPtr, we - * do surgery to transfer our desired intrep into it. - * + * to change. So rather than replace lePtr->objPtr, we do + * surgery to transfer our desired intrep into it. */ + objPtr->typePtr = literal->typePtr; objPtr->internalRep = literal->internalRep; literal->typePtr = NULL; @@ -2347,13 +2382,14 @@ CompileExprTree( TclEmitPush(index, envPtr); } else { /* - * When optimize==0, we know the expression is a one-off - * and there's nothing to be gained from sharing literals - * when they won't live long, and the copies we have already - * have an appropriate intrep. In this case, skip literal + * When optimize==0, we know the expression is a one-off and + * there's nothing to be gained from sharing literals when + * they won't live long, and the copies we have already have + * an appropriate intrep. In this case, skip literal * registration that would enable sharing, and use the routine * that preserves intreps. */ + TclEmitPush(TclAddLiteralObj(envPtr, literal, NULL), envPtr); } (*litObjvPtr)++; @@ -2367,6 +2403,7 @@ CompileExprTree( default: if (optimize && nodes[next].constant) { Tcl_InterpState save = Tcl_SaveInterpState(interp, TCL_OK); + if (ExecConstantExprTree(interp, nodes, next, litObjvPtr) == TCL_OK) { TclEmitPush(TclAddLiteralObj(envPtr, @@ -2408,7 +2445,7 @@ TclSingleOpCmd( int objc, Tcl_Obj *const objv[]) { - TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; + TclOpCmdClientData *occdPtr = clientData; unsigned char lexeme; OpNode nodes[2]; Tcl_Obj *const *litObjv = objv + 1; @@ -2439,10 +2476,11 @@ TclSingleOpCmd( *---------------------------------------------------------------------- * * TclSortingOpCmd -- - * Implements the commands: <, <=, >, >=, ==, eq - * in the ::tcl::mathop namespace. These commands are defined for + * Implements the commands: + * <, <=, >, >=, ==, eq + * in the ::tcl::mathop namespace. These commands are defined for * arbitrary number of arguments by computing the AND of the base - * operator applied to all neighbor argument pairs. + * operator applied to all neighbor argument pairs. * * Results: * A standard Tcl return code and result left in interp. @@ -2465,7 +2503,7 @@ TclSortingOpCmd( if (objc < 3) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); } else { - TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; + TclOpCmdClientData *occdPtr = clientData; Tcl_Obj **litObjv = (Tcl_Obj **) TclStackAlloc(interp, 2*(objc-2)*sizeof(Tcl_Obj *)); OpNode *nodes = (OpNode *) TclStackAlloc(interp, @@ -2520,9 +2558,9 @@ TclSortingOpCmd( * * TclVariadicOpCmd -- * Implements the commands: +, *, &, |, ^, ** - * in the ::tcl::mathop namespace. These commands are defined for + * in the ::tcl::mathop namespace. These commands are defined for * arbitrary number of arguments by repeatedly applying the base - * operator with suitable associative rules. When fewer than two + * operator with suitable associative rules. When fewer than two * arguments are provided, suitable identity values are returned. * * Results: @@ -2541,7 +2579,7 @@ TclVariadicOpCmd( int objc, Tcl_Obj *const objv[]) { - TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; + TclOpCmdClientData *occdPtr = clientData; unsigned char lexeme; int code; @@ -2603,7 +2641,7 @@ TclVariadicOpCmd( nodes[0].lexeme = START; nodes[0].mark = MARK_RIGHT; if (lexeme == EXPON) { - for (i=objc-2; i>0; i-- ) { + for (i=objc-2; i>0; i--) { nodes[i].lexeme = lexeme; nodes[i].mark = MARK_LEFT; nodes[i].left = OT_LITERAL; @@ -2614,7 +2652,7 @@ TclVariadicOpCmd( lastOp = i; } } else { - for (i=1; i<objc-1; i++ ) { + for (i=1; i<objc-1; i++) { nodes[i].lexeme = lexeme; nodes[i].mark = MARK_LEFT; nodes[i].left = lastOp; @@ -2631,7 +2669,6 @@ TclVariadicOpCmd( code = ExecConstantExprTree(interp, nodes, 0, &litObjv); TclStackFree(interp, nodes); - return code; } } @@ -2641,10 +2678,10 @@ TclVariadicOpCmd( * * TclNoIdentOpCmd -- * Implements the commands: -, / - * in the ::tcl::mathop namespace. These commands are defined for - * arbitrary non-zero number of arguments by repeatedly applying - * the base operator with suitable associative rules. When no - * arguments are provided, an error is raised. + * in the ::tcl::mathop namespace. These commands are defined for + * arbitrary non-zero number of arguments by repeatedly applying the base + * operator with suitable associative rules. When no arguments are + * provided, an error is raised. * * Results: * A standard Tcl return code and result left in interp. @@ -2662,7 +2699,8 @@ TclNoIdentOpCmd( int objc, Tcl_Obj *const objv[]) { - TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; + TclOpCmdClientData *occdPtr = clientData; + if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected); return TCL_ERROR; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 94e3c61..d93e321 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.163 2008/11/27 08:23:51 ferrieux Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.164 2009/01/09 11:21:45 dkf Exp $ */ #include "tclInt.h" @@ -432,9 +432,8 @@ static void PrintSourceToObj(Tcl_Obj *appendObj, static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token *tokenPtr, const char *cmd, int len, int numWords, int line, int **lines); - -static void EnterCmdWordIndex (ExtCmdLoc *eclPtr, Tcl_Obj* obj, - int pc, int word); +static void EnterCmdWordIndex(ExtCmdLoc *eclPtr, Tcl_Obj* obj, + int pc, int word); /* * The structure below defines the bytecode Tcl object type by means of @@ -914,9 +913,8 @@ TclInitCompileEnv( envPtr->extCmdMapPtr->neiloc = 0; envPtr->extCmdMapPtr->nueiloc = 0; - if ((invoker == NULL) || - (invoker->type == TCL_LOCATION_EVAL_LIST)) { - /* + if ((invoker == NULL) || (invoker->type == TCL_LOCATION_EVAL_LIST)) { + /* * Initialize the compiler for relative counting in case of a * dynamic context. */ @@ -925,7 +923,7 @@ TclInitCompileEnv( envPtr->extCmdMapPtr->type = (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC); } else { - /* + /* * Initialize the compiler using the context, making counting absolute * to that context. Note that the context can be byte code execution. * In that case we have to fill out the missing pieces (line, path, @@ -941,7 +939,7 @@ TclInitCompileEnv( if (invoker->type == TCL_LOCATION_BC) { /* * Note: Type BC => ctx.data.eval.path is not used. - * ctx.data.tebc.codePtr is used instead. + * ctx.data.tebc.codePtr is used instead. */ TclGetSrcInfoForPc(ctxPtr); @@ -1451,7 +1449,8 @@ TclCompileScript( tokenPtr[1].start, tokenPtr[1].size); if (cmdPtr != NULL) { TclSetCmdNameObj(interp, - envPtr->literalArrayPtr[objIndex].objPtr,cmdPtr); + envPtr->literalArrayPtr[objIndex].objPtr, + cmdPtr); } if ((wordIdx == 0) && (parsePtr->numWords == 1)) { /* @@ -1898,8 +1897,8 @@ TclCompileExprWords( * * Side effects: * Instructions are added to envPtr to execute a no-op at runtime. No - * result is pushed onto the stack: the compiler has to take care of this - * itself if the last compiled command is a NoOp. + * result is pushed onto the stack: the compiler has to take care of this + * itself if the last compiled command is a NoOp. * *---------------------------------------------------------------------- */ @@ -2131,7 +2130,7 @@ TclFindCompiledLocal( int nameBytes, /* Number of bytes in the name. */ int create, /* If 1, allocate a local frame entry for the * variable if it is new. */ - CompileEnv *envPtr) /* Points to the current compile environment*/ + CompileEnv *envPtr) /* Points to the current compile environment*/ { register CompiledLocal *localPtr; int localVar = -1; @@ -2466,7 +2465,7 @@ EnterCmdWordData( wordLine = line; for (wordIdx=0 ; wordIdx<numWords; wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { - TclAdvanceLines(&wordLine, last, tokenPtr->start); + TclAdvanceLines(&wordLine, last, tokenPtr->start); wwlines[wordIdx] = (TclWordKnownAtCompileTime(tokenPtr, NULL) ? wordLine : -1); ePtr->line[wordIdx] = wordLine; @@ -2478,36 +2477,36 @@ EnterCmdWordData( } static void -EnterCmdWordIndex ( - ExtCmdLoc *eclPtr, - Tcl_Obj* obj, - int pc, - int word) +EnterCmdWordIndex( + ExtCmdLoc *eclPtr, + Tcl_Obj *obj, + int pc, + int word) { ExtIndex* eiPtr; if (eclPtr->nueiloc >= eclPtr->neiloc) { /* - * Expand the ExtIndex array by allocating more storage from the heap. The - * currently allocated ECL entries are stored from eclPtr->loc[0] up - * to eclPtr->loc[eclPtr->nuloc-1] (inclusive). + * Expand the ExtIndex array by allocating more storage from the heap. + * The currently allocated ECL entries are stored from eclPtr->loc[0] + * up to eclPtr->loc[eclPtr->nuloc-1] (inclusive). */ size_t currElems = eclPtr->neiloc; size_t newElems = (currElems ? 2*currElems : 1); size_t newBytes = newElems * sizeof(ExtIndex); - eclPtr->eiloc = (ExtIndex *) ckrealloc((char *)(eclPtr->eiloc), newBytes); + eclPtr->eiloc = (ExtIndex *) + ckrealloc((char *)(eclPtr->eiloc), newBytes); eclPtr->neiloc = newElems; } eiPtr = &eclPtr->eiloc[eclPtr->nueiloc]; - - eiPtr->obj = obj; - eiPtr->pc = pc; + eiPtr->obj = obj; + eiPtr->pc = pc; eiPtr->word = word; - eclPtr->nueiloc ++; + eclPtr->nueiloc++; } /* diff --git a/generic/tclConfig.c b/generic/tclConfig.c index b2d3fbb..0bcd0d8 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclConfig.c,v 1.24 2008/10/16 22:34:18 nijtmans Exp $ + * RCS: @(#) $Id: tclConfig.c,v 1.25 2009/01/09 11:21:45 dkf Exp $ */ #include "tclInt.h" @@ -179,7 +179,7 @@ Tcl_RegisterConfig( if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName), QueryConfigObjCmd, cdPtr, QueryConfigDelete) == NULL) { - Tcl_Panic("%s: %s", "Tcl_RegisterConfig", + Tcl_Panic("%s: %s", "Tcl_RegisterConfig", "Unable to create query command for package configuration"); } @@ -233,12 +233,12 @@ QueryConfigObjCmd( pDB = GetConfigDict(interp); if (Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict) != TCL_OK || pkgDict == NULL) { - /* + /* * Maybe a Tcl_Panic is better, because the package data has to be * present. */ - Tcl_SetResult(interp, "package not known", TCL_STATIC); + Tcl_SetResult(interp, "package not known", TCL_STATIC); return TCL_ERROR; } diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 1212dac..5c4295e 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDictObj.c,v 1.74 2009/01/08 16:41:34 dkf Exp $ + * RCS: @(#) $Id: tclDictObj.c,v 1.75 2009/01/09 11:21:45 dkf Exp $ */ #include "tclInt.h" @@ -162,7 +162,7 @@ typedef struct Dict { const Tcl_ObjType tclDictType = { "dict", FreeDictInternalRep, /* freeIntRepProc */ - DupDictInternalRep, /* dupIntRepProc */ + DupDictInternalRep, /* dupIntRepProc */ UpdateStringOfDict, /* updateStringProc */ SetDictFromAny /* setFromAnyProc */ }; @@ -668,8 +668,8 @@ SetDictFromAny( } TclNewObj(keyPtr); - keyPtr->bytes = s; - keyPtr->length = elemSize; + keyPtr->bytes = s; + keyPtr->length = elemSize; p = nextElem; lenRemain = (limit - nextElem); @@ -704,8 +704,8 @@ SetDictFromAny( } TclNewObj(valuePtr); - valuePtr->bytes = s; - valuePtr->length = elemSize; + valuePtr->bytes = s; + valuePtr->length = elemSize; /* * Store key and value in the hash table we're building. diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c6e0d4f..d1c29eb 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.423 2008/12/18 23:00:39 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.424 2009/01/09 11:21:45 dkf Exp $ */ #include "tclInt.h" @@ -174,14 +174,14 @@ static BuiltinFunc const tclBuiltinFuncTable[] = { typedef struct BottomData { struct BottomData *prevBottomPtr; - TEOV_callback *rootPtr; /* State when this bytecode execution began: */ - ByteCode *codePtr; /* constant until it returns */ - /* ------------------------------------------*/ - TEOV_callback *atExitPtr; /* This field is used on return FROM here */ - /* ------------------------------------------*/ - unsigned char *pc; /* These fields are used on return TO this */ - ptrdiff_t *catchTop; /* this level: they record the state when a */ - int cleanup; /* new codePtr was received for NR execution */ + TEOV_callback *rootPtr; /* State when this bytecode execution began: */ + ByteCode *codePtr; /* constant until it returns */ + /* ------------------------------------------*/ + TEOV_callback *atExitPtr; /* This field is used on return FROM here */ + /* ------------------------------------------*/ + unsigned char *pc; /* These fields are used on return TO this */ + ptrdiff_t *catchTop; /* this level: they record the state when a */ + int cleanup; /* new codePtr was received for NR execution */ Tcl_Obj *auxObjList; } BottomData; @@ -1546,7 +1546,7 @@ TclCompileObj( } } - /* + /* * Increment the code's ref count while it is being executed. If * afterwards no references to it remain, free the code. */ @@ -1786,10 +1786,10 @@ TclExecuteByteCode( ptrdiff_t *catchTop = 0; register Tcl_Obj **tosPtr = NULL; - /* Cached pointer to top of evaluation + /* Cached pointer to top of evaluation * stack. */ register unsigned char *pc = NULL; - /* The current program counter. */ + /* The current program counter. */ int instructionCount = 0; /* Counter that is used to work out when to * call Tcl_AsyncReady() */ Tcl_Obj *auxObjList = NULL; /* Linked list of aux data, used for {*} and @@ -1948,35 +1948,36 @@ TclExecuteByteCode( case TCL_NR_YIELD_TYPE: { /*[yield] */ CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - if (!corPtr) { - Tcl_SetResult(interp, - "yield can only be called in a coroutine", TCL_STATIC); - Tcl_SetErrorCode(interp, "COROUTINE_ILLEGAL_YIELD", NULL); - result = TCL_ERROR; - goto checkForCatch; - } - NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr); - NRE_ASSERT(corPtr->stackLevel != NULL); - NRE_ASSERT(bottomPtr == corPtr->eePtr->bottomPtr); - if (corPtr->stackLevel != &initLevel) { - Tcl_SetResult(interp, - "cannot yield: C stack busy", TCL_STATIC); - Tcl_SetErrorCode(interp, "COROUTINE_CANT_YIELD", NULL); - result = TCL_ERROR; - goto checkForCatch; - } - - /* - * Save our state, restore the caller's execEnv and return - */ - - NR_DATA_BURY(); - esPtr->tosPtr = tosPtr; - corPtr->stackLevel = NULL; /* mark suspended */ - iPtr->execEnvPtr->bottomPtr = bottomPtr; - - iPtr->execEnvPtr = corPtr->callerEEPtr; - return TCL_OK; + if (!corPtr) { + Tcl_SetResult(interp, + "yield can only be called in a coroutine", + TCL_STATIC); + Tcl_SetErrorCode(interp, "COROUTINE_ILLEGAL_YIELD", NULL); + result = TCL_ERROR; + goto checkForCatch; + } + NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr); + NRE_ASSERT(corPtr->stackLevel != NULL); + NRE_ASSERT(bottomPtr == corPtr->eePtr->bottomPtr); + if (corPtr->stackLevel != &initLevel) { + Tcl_SetResult(interp, "cannot yield: C stack busy", + TCL_STATIC); + Tcl_SetErrorCode(interp, "COROUTINE_CANT_YIELD", NULL); + result = TCL_ERROR; + goto checkForCatch; + } + + /* + * Save our state, restore the caller's execEnv and return + */ + + NR_DATA_BURY(); + esPtr->tosPtr = tosPtr; + corPtr->stackLevel = NULL; /* mark suspended */ + iPtr->execEnvPtr->bottomPtr = bottomPtr; + + iPtr->execEnvPtr = corPtr->callerEEPtr; + return TCL_OK; } default: Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!"); @@ -2083,8 +2084,8 @@ TclExecuteByteCode( } #endif } else { - cleanup = 0; /* already cleaned up */ - pc--; /* was pointing to next instruction */ + cleanup = 0; /* already cleaned up */ + pc--; /* was pointing to next instruction */ goto processExceptionReturn; } } @@ -2563,7 +2564,7 @@ TclExecuteByteCode( p += length; } } - } + } TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, opnd, 1); @@ -7836,7 +7837,7 @@ TclExecuteByteCode( oldBottomPtr = bottomPtr->prevBottomPtr; atExitPtr = bottomPtr->atExitPtr; iPtr->cmdFramePtr = bcFramePtr->nextPtr; - TclStackFree(interp, bottomPtr); /* free my stack */ + TclStackFree(interp, bottomPtr); /* free my stack */ if (--codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); @@ -7849,9 +7850,9 @@ TclExecuteByteCode( * with atExit handlers and tailcalls. */ - bottomPtr = oldBottomPtr; /* back to old bc */ + bottomPtr = oldBottomPtr; /* back to old bc */ - rerunCallbacks: + rerunCallbacks: result = TclNRRunCallbacks(interp, result, bottomPtr->rootPtr, 1); NR_DATA_DIG(); @@ -7873,8 +7874,10 @@ TclExecuteByteCode( } NRE_ASSERT(lastPtr->nextPtr == NULL); if (!isTailcall) { - /* save the interp state, arrange for restoring it after - running the callbacks.*/ + /* + * Save the interp state, arrange for restoring it after + * running the callbacks. + */ TclNRAddCallback(interp, NRRestoreInterpState, Tcl_SaveInterpState(interp, result), NULL, @@ -7907,8 +7910,8 @@ TclExecuteByteCode( switch (type) { case TCL_NR_BC_TYPE: /* - * One of the callbacks requested a new execution: a tailcall! - * Start the new bytecode. + * One of the callbacks requested a new execution: a + * tailcall! Start the new bytecode. */ goto nonRecursiveCallStart; @@ -7918,7 +7921,8 @@ TclExecuteByteCode( TCLNR_FREE(interp, callbackPtr); Tcl_SetResult(interp, - "atProcExit/tailcall cannot be invoked recursively", TCL_STATIC); + "atProcExit/tailcall cannot be invoked recursively", + TCL_STATIC); result = TCL_ERROR; goto rerunCallbacks; default: @@ -7930,9 +7934,11 @@ TclExecuteByteCode( if (atExitPtr) { if (!isTailcall) { - /* save the interp state, arrange for restoring it after - running the callbacks. Put the callback at the bottom of the - atExit stack */ + /* + * Save the interp state, arrange for restoring it after running + * the callbacks. Put the callback at the bottom of the atExit + * stack. + */ Tcl_InterpState state = Tcl_SaveInterpState(interp, result); TEOV_callback *lastPtr = atExitPtr; @@ -8219,7 +8225,7 @@ TclGetSrcInfoForPc( } srcOffset = cfPtr->cmd.str.cmd - codePtr->source; - eclPtr = (ExtCmdLoc *) Tcl_GetHashValue (hePtr); + eclPtr = (ExtCmdLoc *) Tcl_GetHashValue(hePtr); for (i=0; i < eclPtr->nuloc; i++) { if (eclPtr->loc[i].srcOffset == srcOffset) { diff --git a/generic/tclHash.c b/generic/tclHash.c index 89fbb6f..218d8e1 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclHash.c,v 1.37 2008/11/17 22:15:34 nijtmans Exp $ + * RCS: @(#) $Id: tclHash.c,v 1.38 2009/01/09 11:21:45 dkf Exp $ */ #include "tclInt.h" @@ -283,13 +283,13 @@ Tcl_CreateHashEntry( if (typePtr->hashKeyProc) { hash = typePtr->hashKeyProc(tablePtr, (void *) key); if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX (tablePtr, hash); + index = RANDOM_INDEX(tablePtr, hash); } else { index = hash & tablePtr->mask; } } else { hash = PTR2UINT(key); - index = RANDOM_INDEX (tablePtr, hash); + index = RANDOM_INDEX(tablePtr, hash); } /* @@ -298,6 +298,7 @@ Tcl_CreateHashEntry( if (typePtr->compareKeysProc) { Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc; + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { #if TCL_HASH_KEY_STORE_HASH @@ -441,7 +442,7 @@ Tcl_DeleteHashEntry( tablePtr->numEntries--; if (typePtr->freeEntryProc) { - typePtr->freeEntryProc (entryPtr); + typePtr->freeEntryProc(entryPtr); } else { ckfree((char *) entryPtr); } @@ -492,7 +493,7 @@ Tcl_DeleteHashTable( while (hPtr != NULL) { nextPtr = hPtr->nextPtr; if (typePtr->freeEntryProc) { - typePtr->freeEntryProc (hPtr); + typePtr->freeEntryProc(hPtr); } else { ckfree((char *) hPtr); } @@ -1041,7 +1042,7 @@ RebuildTable( #if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX (tablePtr, hPtr->hash); + index = RANDOM_INDEX(tablePtr, hPtr->hash); } else { index = PTR2UINT(hPtr->hash) & tablePtr->mask; } @@ -1055,12 +1056,12 @@ RebuildTable( hash = typePtr->hashKeyProc(tablePtr, key); if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX (tablePtr, hash); + index = RANDOM_INDEX(tablePtr, hash); } else { index = hash & tablePtr->mask; } } else { - index = RANDOM_INDEX (tablePtr, key); + index = RANDOM_INDEX(tablePtr, key); } hPtr->bucketPtr = &(tablePtr->buckets[index]); diff --git a/generic/tclIO.c b/generic/tclIO.c index b3df82e..3ed45a2 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.157 2008/12/18 23:48:39 andreas_kupries Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.158 2009/01/09 11:21:45 dkf Exp $ */ #include "tclInt.h" @@ -64,7 +64,7 @@ static int CloseChannel(Tcl_Interp *interp, Channel *chanPtr, int errorCode); static int CloseChannelPart(Tcl_Interp *interp, Channel *chanPtr, int errorCode, int flags); -static int CloseWrite(Tcl_Interp *interp, Channel* chanPtr); +static int CloseWrite(Tcl_Interp *interp, Channel* chanPtr); static void CommonGetsCleanup(Channel *chanPtr); static int CopyAndTranslateBuffer(ChannelState *statePtr, char *result, int space); @@ -3101,7 +3101,7 @@ Tcl_Close( * * Tcl_CloseEx -- * - * Closes one side of a channel, read or write. + * Closes one side of a channel, read or write. * * Results: * A standard Tcl result. @@ -3122,8 +3122,9 @@ Tcl_Close( int Tcl_CloseEx( Tcl_Interp *interp, /* Interpreter for errors. */ - Tcl_Channel chan, /* The channel being closed. May still be used by some interpreter */ - int flags) /* Flags telling us which side to close. */ + Tcl_Channel chan, /* The channel being closed. May still be used + * by some interpreter. */ + int flags) /* Flags telling us which side to close. */ { Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of real IO channel. */ @@ -3138,12 +3139,12 @@ Tcl_CloseEx( statePtr = chanPtr->state; /* - * Does the channel support half-close anyway ? Error if not. + * Does the channel support half-close anyway? Error if not. */ if (!chanPtr->typePtr->close2Proc) { - Tcl_AppendResult (interp, "Half-close of channels not supported by ", - chanPtr->typePtr->typeName, "s", NULL); + Tcl_AppendResult(interp, "Half-close of channels not supported by ", + chanPtr->typePtr->typeName, "s", NULL); return TCL_ERROR; } @@ -3152,9 +3153,9 @@ Tcl_CloseEx( */ if (chanPtr != statePtr->topChanPtr) { - Tcl_AppendResult (interp, - "Half-close not applicable to stack of transformations", - NULL); + Tcl_AppendResult(interp, + "Half-close not applicable to stack of transformations", + NULL); return TCL_ERROR; } @@ -3166,14 +3167,15 @@ Tcl_CloseEx( if (!(statePtr->flags & (TCL_READABLE | TCL_WRITABLE) & flags)) { const char *msg; + if (flags & TCL_CLOSE_READ) { msg = "read"; } else { msg = "write"; } - Tcl_AppendResult (interp, "Half-close of ", msg, - "-side not possible, side not opened or already closed", - NULL); + Tcl_AppendResult(interp, "Half-close of ", msg, + "-side not possible, side not opened or already closed", + NULL); return TCL_ERROR; } @@ -3196,10 +3198,8 @@ Tcl_CloseEx( * there cannot be for the read-side. */ - return CloseChannelPart (interp, chanPtr, 0, flags); - + return CloseChannelPart(interp, chanPtr, 0, flags); } else if (flags & TCL_CLOSE_WRITE) { - if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) { SetFlag(statePtr, BUFFER_READY); @@ -3307,12 +3307,10 @@ CloseWrite( * * CloseChannelPart -- * - * Utility procedure to close a channel partially and free associated resources. - * - * If the channel was stacked it will never be run (The higher level forbid this). - * - * If the channel was not stacked, then we will free all the bits of the - * chosen side (read, or write) for the TOP channel. + * Utility procedure to close a channel partially and free associated + * resources. If the channel was stacked it will never be run (The higher + * level forbid this). If the channel was not stacked, then we will free + * all the bits of the chosen side (read, or write) for the TOP channel. * * Results: * Error code from an unreported error or the driver close2 operation. @@ -3326,9 +3324,10 @@ CloseWrite( static int CloseChannelPart( Tcl_Interp *interp, /* Interpreter for errors. */ - Channel* chanPtr, /* The channel being closed. May still be used by some interpreter */ - int errorCode, /* Status of operation so far. */ - int flags) /* Flags telling us which side to close. */ + Channel* chanPtr, /* The channel being closed. May still be used + * by some interpreter. */ + int errorCode, /* Status of operation so far. */ + int flags) /* Flags telling us which side to close. */ { ChannelState *statePtr; /* State of real IO channel. */ int result; /* Of calling the close2proc. */ @@ -3341,16 +3340,15 @@ CloseChannelPart( */ DiscardInputQueued(statePtr, 1); - } else if (flags & TCL_CLOSE_WRITE) { - /* * The caller guarantees that there are no more buffers queued for * output. */ if (statePtr->outQueueHead != NULL) { - Tcl_Panic("ClosechanHalf, closed write-side of channel: queued output left"); + Tcl_Panic("ClosechanHalf, closed write-side of channel: " + "queued output left"); } /* @@ -3386,7 +3384,7 @@ CloseChannelPart( * message in the interp. */ - result = ChanCloseHalf (chanPtr, interp, flags); + result = ChanCloseHalf(chanPtr, interp, flags); /* * If we are being called synchronously, report either any latent error on @@ -3436,7 +3434,7 @@ CloseChannelPart( * Remove the closed side from the channel mode/flags. */ - ResetFlag (statePtr, flags & (TCL_READABLE | TCL_WRITABLE)); + ResetFlag(statePtr, flags & (TCL_READABLE | TCL_WRITABLE)); return TCL_OK; } @@ -10985,7 +10983,7 @@ DupChannelIntRep( * currently have an internal rep.*/ { ChannelState *statePtr = GET_CHANNELSTATE(srcPtr); - Interp *interpPtr = GET_CHANNELINTERP(srcPtr); + Interp *interpPtr = GET_CHANNELINTERP(srcPtr); SET_CHANNELSTATE(copyPtr, statePtr); SET_CHANNELINTERP(copyPtr, interpPtr); @@ -11016,7 +11014,7 @@ SetChannelFromAny( register Tcl_Obj *objPtr) /* The object to convert. */ { ChannelState *statePtr; - Interp *interpPtr; + Interp *interpPtr; if (objPtr->typePtr == &tclChannelType) { /* diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 94bbb5c..95f4ebc 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOCmd.c,v 1.61 2008/12/18 01:14:16 ferrieux Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.62 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -680,10 +680,11 @@ Tcl_CloseObjCmd( * never opened for that direction). */ - if (!(dir & Tcl_GetChannelMode (chan))) { - Tcl_AppendResult (interp, "Half-close of ", dirOptions[optionIndex], - "-side not possible, side not opened or already closed", - NULL); + if (!(dir & Tcl_GetChannelMode(chan))) { + Tcl_AppendResult(interp, "Half-close of ", + dirOptions[optionIndex], + "-side not possible, side not opened or already closed", + NULL); return TCL_ERROR; } @@ -694,8 +695,9 @@ Tcl_CloseObjCmd( * process. */ - if ((Tcl_GetChannelMode (chan) & (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) != dir) { - return Tcl_CloseEx (interp, chan, dir) != TCL_OK; + if ((Tcl_GetChannelMode(chan) & + (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) != dir) { + return Tcl_CloseEx(interp, chan, dir); } } @@ -1931,9 +1933,9 @@ TclInitChanCmd( {"flush", Tcl_FlushObjCmd}, {"gets", Tcl_GetsObjCmd}, {"pending", ChanPendingObjCmd}, /* TIP #287 */ - {"pop", TclChanPopObjCmd}, /* TIP #230 */ + {"pop", TclChanPopObjCmd}, /* TIP #230 */ {"postevent", TclChanPostEventObjCmd}, /* TIP #219 */ - {"push", TclChanPushObjCmd}, /* TIP #230 */ + {"push", TclChanPushObjCmd}, /* TIP #230 */ {"puts", Tcl_PutsObjCmd}, {"read", Tcl_ReadObjCmd}, {"seek", Tcl_SeekObjCmd}, diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 679f393..d93df6b 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIORChan.c,v 1.35 2008/10/16 22:34:19 nijtmans Exp $ + * RCS: @(#) $Id: tclIORChan.c,v 1.36 2009/01/09 11:21:46 dkf Exp $ */ #include <tclInt.h> @@ -58,23 +58,23 @@ static int ReflectSetOption(ClientData clientData, */ static Tcl_ChannelType tclRChannelType = { - "tclrchannel", /* Type name. */ + "tclrchannel", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - ReflectClose, /* Close channel, clean instance data */ - ReflectInput, /* Handle read request */ - ReflectOutput, /* Handle write request */ - ReflectSeek, /* Move location of access point. NULL'able */ - ReflectSetOption, /* Set options. NULL'able */ - ReflectGetOption, /* Get options. NULL'able */ - ReflectWatch, /* Initialize notifier */ - NULL, /* Get OS handle from the channel. NULL'able */ - NULL, /* No close2 support. NULL'able */ - ReflectBlock, /* Set blocking/nonblocking. NULL'able */ - NULL, /* Flush channel. Not used by core. NULL'able */ - NULL, /* Handle events. NULL'able */ - ReflectSeekWide, /* Move access point (64 bit). NULL'able */ - NULL, /* thread action */ - NULL, /* truncate */ + ReflectClose, /* Close channel, clean instance data */ + ReflectInput, /* Handle read request */ + ReflectOutput, /* Handle write request */ + ReflectSeek, /* Move location of access point. NULL'able */ + ReflectSetOption, /* Set options. NULL'able */ + ReflectGetOption, /* Get options. NULL'able */ + ReflectWatch, /* Initialize notifier */ + NULL, /* Get OS handle from the channel. NULL'able */ + NULL, /* No close2 support. NULL'able */ + ReflectBlock, /* Set blocking/nonblocking. NULL'able */ + NULL, /* Flush channel. Not used by core. NULL'able */ + NULL, /* Handle events. NULL'able */ + ReflectSeekWide, /* Move access point (64 bit). NULL'able */ + NULL, /* thread action */ + NULL, /* truncate */ }; /* @@ -716,7 +716,7 @@ TclChanCreateObjCmd( Tcl_RegisterChannel(interp, chan); - rcmPtr = GetReflectedChannelMap (interp); + rcmPtr = GetReflectedChannelMap(interp); hPtr = Tcl_CreateHashEntry(&rcmPtr->map, chanPtr->state->channelName, &isNew); if (!isNew && chanPtr != Tcl_GetHashValue(hPtr)) { @@ -814,12 +814,12 @@ TclChanPostEventObjCmd( chanId = TclGetString(objv[CHAN]); - rcmPtr = GetReflectedChannelMap (interp); - hPtr = Tcl_FindHashEntry (&rcmPtr->map, chanId); + rcmPtr = GetReflectedChannelMap(interp); + hPtr = Tcl_FindHashEntry(&rcmPtr->map, chanId); if (hPtr == NULL) { - Tcl_AppendResult(interp, "can not find reflected channel named \"", chanId, - "\"", NULL); + Tcl_AppendResult(interp, "can not find reflected channel named \"", + chanId, "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, NULL); return TCL_ERROR; } @@ -840,7 +840,7 @@ TclChanPostEventObjCmd( * have gone seriously haywire. */ - chan = Tcl_GetHashValue(hPtr); + chan = Tcl_GetHashValue(hPtr); chanTypePtr = Tcl_GetChannelType(chan); /* @@ -853,13 +853,13 @@ TclChanPostEventObjCmd( */ if (chanTypePtr->watchProc != &ReflectWatch) { - Tcl_Panic ("TclChanPostEventObjCmd: channel is not a reflected channel"); + Tcl_Panic("TclChanPostEventObjCmd: channel is not a reflected channel"); } rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan); if (rcPtr->interp != interp) { - Tcl_Panic ("TclChanPostEventObjCmd: postevent accepted for call from outside interpreter"); + Tcl_Panic("TclChanPostEventObjCmd: postevent accepted for call from outside interpreter"); } /* @@ -1146,7 +1146,7 @@ ReflectClose( Tcl_DeleteHashEntry(hPtr); } #ifdef TCL_THREADS - rcmPtr = GetThreadReflectedChannelMap(); + rcmPtr = GetThreadReflectedChannelMap(); hPtr = Tcl_FindHashEntry(&rcmPtr->map, Tcl_GetChannelName(rcPtr->chan)); if (hPtr) { @@ -2346,7 +2346,7 @@ DeleteReflectedChannelMap( for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch); hPtr != NULL; hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) { - chan = (Tcl_Channel) Tcl_GetHashValue (hPtr); + chan = Tcl_GetHashValue(hPtr); rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan); rcPtr->interp = NULL; @@ -2407,7 +2407,7 @@ DeleteReflectedChannelMap( for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - chan = (Tcl_Channel) Tcl_GetHashValue (hPtr); + chan = Tcl_GetHashValue(hPtr); rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan); if (rcPtr->interp != interp) { @@ -2465,7 +2465,7 @@ GetThreadReflectedChannelMap(void) * * Deletes the channel table for a thread. This procedure is invoked when * a thread is deleted. The channels have already been marked as dead, in - * DeleteReflectedChannelMap(). + * DeleteReflectedChannelMap(). * * Results: * None. @@ -2696,7 +2696,7 @@ ForwardProc( ReflectedChannelMap *rcmPtr; /* Map of reflected channels with handlers in * this interp. */ - Tcl_HashEntry *hPtr; /* Entry in the above map */ + Tcl_HashEntry *hPtr; /* Entry in the above map */ /* * Ignore the event if no one is waiting for its result anymore. @@ -2741,7 +2741,7 @@ ForwardProc( Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); - rcmPtr = GetThreadReflectedChannelMap(); + rcmPtr = GetThreadReflectedChannelMap(); hPtr = Tcl_FindHashEntry(&rcmPtr->map, Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index b550675..b847d42 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIORTrans.c,v 1.6 2008/10/26 18:34:04 dkf Exp $ + * RCS: @(#) $Id: tclIORTrans.c,v 1.7 2009/01/09 11:21:46 dkf Exp $ */ #include <tclInt.h> @@ -97,7 +97,7 @@ typedef struct _ResultBuffer_ { } ResultBuffer; #define ResultLength(r) ((r)->used) -/* static int ResultLength (ResultBuffer *r); */ +/* static int ResultLength(ResultBuffer *r); */ static void ResultClear(ResultBuffer *r); static void ResultInit(ResultBuffer *r); @@ -1137,7 +1137,7 @@ ReflectInput( } *errorCodePtr = Tcl_GetErrno(); - return -1; + return -1; } if (read == 0) { @@ -1193,7 +1193,7 @@ ReflectInput( * Reset eof, force caller to drain result buffer. */ - ((Channel *) rtPtr->parent)->state->flags &= ~CHANNEL_EOF; + ((Channel *) rtPtr->parent)->state->flags &= ~CHANNEL_EOF; continue; /* at: while (toRead > 0) */ } } /* read == 0 */ @@ -1364,7 +1364,7 @@ ReflectSeekWide( curPos = parent->typePtr->wideSeekProc(parent->instanceData, offset, seekMode, errorCodePtr); } else if (offset < Tcl_LongAsWide(LONG_MIN) || - offset > Tcl_LongAsWide(LONG_MAX)) { + offset > Tcl_LongAsWide(LONG_MAX)) { *errorCodePtr = EOVERFLOW; curPos = Tcl_LongAsWide(-1); } else { @@ -2242,7 +2242,7 @@ GetThreadReflectedTransformMap(void) * * Deletes the channel table for a thread. This procedure is invoked when * a thread is deleted. The channels have already been marked as dead, in - * DeleteReflectedTransformMap(). + * DeleteReflectedTransformMap(). * * Results: * None. @@ -2523,7 +2523,7 @@ ForwardProc( * channel by deleting the owning thread. */ - rtmPtr = GetThreadReflectedTransformMap(); + rtmPtr = GetThreadReflectedTransformMap(); hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); Tcl_DeleteHashEntry(hPtr); FreeReflectedTransform(rtPtr); diff --git a/generic/tclInterp.c b/generic/tclInterp.c index ac8cbb9..0abbbde 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInterp.c,v 1.99 2008/12/09 20:16:30 dgp Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.100 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -2620,20 +2620,19 @@ SlaveEval( * compiling. */ - Interp *iPtr = (Interp *) interp; - CmdFrame* invoker = iPtr->cmdFramePtr; - int word = 0; + Interp *iPtr = (Interp *) interp; + CmdFrame *invoker = iPtr->cmdFramePtr; + int word = 0; objPtr = objv[0]; - if (objPtr->typePtr - && (objPtr->typePtr != &tclByteCodeType) + if (objPtr->typePtr && (objPtr->typePtr != &tclByteCodeType) && objPtr->typePtr->freeIntRepProc) { (void) TclGetString(objPtr); TclFreeIntRep(objPtr); objPtr->typePtr = NULL; } - TclArgumentGet (interp, objPtr, &invoker, &word); + TclArgumentGet(interp, objPtr, &invoker, &word); result = TclEvalObjEx(slaveInterp, objPtr, 0, invoker, word); } else { diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 0a45f4d..a176e8d 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLiteral.c,v 1.33 2007/12/13 15:23:19 dgp Exp $ + * RCS: @(#) $Id: tclLiteral.c,v 1.34 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -131,7 +131,7 @@ TclCleanupLiteralTable( typePtr = objPtr->typePtr; if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { if (objPtr->bytes == NULL) { - Tcl_Panic( "literal without a string rep" ); + Tcl_Panic("literal without a string rep"); } objPtr->typePtr = NULL; typePtr->freeIntRepProc(objPtr); @@ -225,16 +225,16 @@ TclDeleteLiteralTable( * * Results: * The literal object. If it was created in this call *newPtr is set to - * 1, else 0. NULL is returned if newPtr==NULL and no literal is found. + * 1, else 0. NULL is returned if newPtr==NULL and no literal is found. * * Side effects: - * Increments the ref count of the global LiteralEntry since the caller - * now holds a reference. - * If LITERAL_ON_HEAP is set in flags, this function is given ownership - * of the string: if an object is created then its string representation - * is set directly from string, otherwise the string is freed. Typically, - * a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated - * buffer holding the result of backslash substitutions. + * Increments the ref count of the global LiteralEntry since the caller + * now holds a reference. If LITERAL_ON_HEAP is set in flags, this + * function is given ownership of the string: if an object is created + * then its string representation is set directly from string, otherwise + * the string is freed. Typically, a caller sets LITERAL_ON_HEAP if + * "string" is an already heap-allocated buffer holding the result of + * backslash substitutions. * *---------------------------------------------------------------------- */ @@ -244,13 +244,14 @@ TclCreateLiteral( Interp *iPtr, char *bytes, int length, - unsigned int hash, /* The string's hash. If -1, it will be computed here */ + unsigned int hash, /* The string's hash. If -1, it will be + * computed here. */ int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr) { - LiteralTable *globalTablePtr = &(iPtr->literalTable); + LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; int globalHash; Tcl_Obj *objPtr; @@ -259,7 +260,7 @@ TclCreateLiteral( * Is it in the interpreter's global literal table? */ - if (hash == (unsigned int) -1) { + if (hash == (unsigned) -1) { hash = HashString(bytes, length); } globalHash = (hash & globalTablePtr->mask); @@ -650,7 +651,7 @@ TclAddLiteralObj( * * Side effects: * Expands the literal array if necessary. May rebuild the hash bucket - * array of the CompileEnv's literal array if it becomes too large. + * array of the CompileEnv's literal array if it becomes too large. * *---------------------------------------------------------------------- */ @@ -659,7 +660,7 @@ static int AddLocalLiteralEntry( register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ - Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */ + Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */ int localHash) /* Hash value for the literal's string. */ { register LiteralTable *localTablePtr = &(envPtr->localLitTable); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 3703118..5908bb1 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -23,7 +23,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.183 2008/12/02 19:40:41 dgp Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.184 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -3332,10 +3332,10 @@ NamespaceEvalCmd( * TIP #280: Make actual argument location available to eval'd script. */ - objPtr = objv[3]; + objPtr = objv[3]; invoker = iPtr->cmdFramePtr; - word = 3; - TclArgumentGet (interp, objPtr, &invoker, &word); + word = 3; + TclArgumentGet(interp, objPtr, &invoker, &word); } else { /* * More than one argument: concatenate them together with spaces @@ -3343,9 +3343,9 @@ NamespaceEvalCmd( * object when it decrements its refcount after eval'ing it. */ - objPtr = Tcl_ConcatObj(objc-3, objv+3); + objPtr = Tcl_ConcatObj(objc-3, objv+3); invoker = NULL; - word = 0; + word = 0; } /* @@ -4879,7 +4879,7 @@ NamespaceEnsembleCmd( * memory leaks. */ - for (; objc>1 ; objc-=2,objv+=2 ) { + for (; objc>1 ; objc-=2,objv+=2) { if (Tcl_GetIndexFromObj(interp, objv[0], createOptions, "option", 0, &index) != TCL_OK) { if (allocatedMapFlag) { @@ -5180,7 +5180,7 @@ NamespaceEnsembleCmd( * cause any memory leaks. */ - for (; objc>0 ; objc-=2,objv+=2 ) { + for (; objc>0 ; objc-=2,objv+=2) { if (Tcl_GetIndexFromObj(interp, objv[0], configOptions, "option", 0, &index) != TCL_OK) { if (allocatedMapFlag) { diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 44c5399..daacc02 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclOOInfo.c,v 1.11 2009/01/06 14:30:19 dkf Exp $ + * RCS: @(#) $Id: tclOOInfo.c,v 1.12 2009/01/09 11:21:46 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -47,15 +47,15 @@ struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; }; */ static const struct NameProcMap infoObjectCmds[] = { - {"::oo::InfoObject::class", InfoObjectClassCmd}, - {"::oo::InfoObject::definition", InfoObjectDefnCmd}, - {"::oo::InfoObject::filters", InfoObjectFiltersCmd}, - {"::oo::InfoObject::forward", InfoObjectForwardCmd}, - {"::oo::InfoObject::isa", InfoObjectIsACmd}, - {"::oo::InfoObject::methods", InfoObjectMethodsCmd}, - {"::oo::InfoObject::mixins", InfoObjectMixinsCmd}, - {"::oo::InfoObject::variables", InfoObjectVariablesCmd}, - {"::oo::InfoObject::vars", InfoObjectVarsCmd}, + {"::oo::InfoObject::class", InfoObjectClassCmd}, + {"::oo::InfoObject::definition", InfoObjectDefnCmd}, + {"::oo::InfoObject::filters", InfoObjectFiltersCmd}, + {"::oo::InfoObject::forward", InfoObjectForwardCmd}, + {"::oo::InfoObject::isa", InfoObjectIsACmd}, + {"::oo::InfoObject::methods", InfoObjectMethodsCmd}, + {"::oo::InfoObject::mixins", InfoObjectMixinsCmd}, + {"::oo::InfoObject::variables", InfoObjectVariablesCmd}, + {"::oo::InfoObject::vars", InfoObjectVarsCmd}, {NULL, NULL} }; @@ -64,17 +64,17 @@ static const struct NameProcMap infoObjectCmds[] = { */ static const struct NameProcMap infoClassCmds[] = { - {"::oo::InfoClass::constructor", InfoClassConstrCmd}, - {"::oo::InfoClass::definition", InfoClassDefnCmd}, - {"::oo::InfoClass::destructor", InfoClassDestrCmd}, - {"::oo::InfoClass::filters", InfoClassFiltersCmd}, - {"::oo::InfoClass::forward", InfoClassForwardCmd}, - {"::oo::InfoClass::instances", InfoClassInstancesCmd}, - {"::oo::InfoClass::methods", InfoClassMethodsCmd}, - {"::oo::InfoClass::mixins", InfoClassMixinsCmd}, - {"::oo::InfoClass::subclasses", InfoClassSubsCmd}, - {"::oo::InfoClass::superclasses", InfoClassSupersCmd}, - {"::oo::InfoClass::variables", InfoClassVariablesCmd}, + {"::oo::InfoClass::constructor", InfoClassConstrCmd}, + {"::oo::InfoClass::definition", InfoClassDefnCmd}, + {"::oo::InfoClass::destructor", InfoClassDestrCmd}, + {"::oo::InfoClass::filters", InfoClassFiltersCmd}, + {"::oo::InfoClass::forward", InfoClassForwardCmd}, + {"::oo::InfoClass::instances", InfoClassInstancesCmd}, + {"::oo::InfoClass::methods", InfoClassMethodsCmd}, + {"::oo::InfoClass::mixins", InfoClassMixinsCmd}, + {"::oo::InfoClass::subclasses", InfoClassSubsCmd}, + {"::oo::InfoClass::superclasses", InfoClassSupersCmd}, + {"::oo::InfoClass::variables", InfoClassVariablesCmd}, {NULL, NULL} }; diff --git a/generic/tclObj.c b/generic/tclObj.c index e73fa17..2b2219a 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.146 2009/01/08 16:41:34 dkf Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.147 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -1319,7 +1319,7 @@ Tcl_GetBooleanFromObj( * sets the proper error message for us. */ - double d; + double d; if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) { return TCL_ERROR; @@ -1706,8 +1706,9 @@ Tcl_GetDoubleFromObj( } if (objPtr->typePtr == &tclBignumType) { mp_int big; - UNPACK_BIGNUM( objPtr, big ); - *dblPtr = TclBignumToDouble( &big ); + + UNPACK_BIGNUM(objPtr, big); + *dblPtr = TclBignumToDouble(&big); return TCL_OK; } #ifndef NO_WIDE_TYPE @@ -2185,8 +2186,8 @@ Tcl_GetLongFromObj( goto tooLarge; } #endif - if (objPtr->typePtr == &tclDoubleType) { - if (interp != NULL) { + if (objPtr->typePtr == &tclDoubleType) { + if (interp != NULL) { Tcl_Obj *msg; TclNewLiteralStringObj(msg, "expected integer but got \""); @@ -2197,7 +2198,7 @@ Tcl_GetLongFromObj( } return TCL_ERROR; } - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType) { /* * Must check for those bignum values that can fit in a long, even * when auto-narrowing is enabled. Only those values in the signed @@ -2488,8 +2489,8 @@ Tcl_GetWideIntFromObj( *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; return TCL_OK; } - if (objPtr->typePtr == &tclDoubleType) { - if (interp != NULL) { + if (objPtr->typePtr == &tclDoubleType) { + if (interp != NULL) { Tcl_Obj *msg; TclNewLiteralStringObj(msg, "expected integer but got \""); @@ -2500,7 +2501,7 @@ Tcl_GetWideIntFromObj( } return TCL_ERROR; } - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType) { /* * Must check for those bignum values that can fit in a * Tcl_WideInt, even when auto-narrowing is enabled. @@ -3050,7 +3051,8 @@ int TclGetNumberFromObj( static Tcl_ThreadDataKey bignumKey; mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, (int) sizeof(mp_int)); - UNPACK_BIGNUM( objPtr, *bigPtr ); + + UNPACK_BIGNUM(objPtr, *bigPtr); *typePtr = TCL_NUMBER_BIG; *clientDataPtr = bigPtr; return TCL_OK; diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 7e4c4ff..b6681a6 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPathObj.c,v 1.76 2008/12/04 17:45:52 dgp Exp $ + * RCS: @(#) $Id: tclPathObj.c,v 1.77 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -321,6 +321,7 @@ TclFSNormalizeAbsolutePath( if (tclPlatform == TCL_PLATFORM_WINDOWS) { int i; + for (i = 0; i < curLen; i++) { if (linkStr[i] == '\\') { linkStr[i] = '/'; @@ -333,8 +334,8 @@ TclFSNormalizeAbsolutePath( } /* - * Either way, we now remove the last path element. - * (but not the first character of the path) + * Either way, we now remove the last path element (but + * not the first character of the path). */ while (--curLen >= 0) { @@ -395,7 +396,7 @@ TclFSNormalizeAbsolutePath( } /* - * Ensure a windows drive like C:/ has a trailing separator + * Ensure a windows drive like C:/ has a trailing separator. */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { @@ -687,6 +688,7 @@ TclPathPart( } else { Tcl_Obj *root = Tcl_NewStringObj(fileName, (int) (length - strlen(extension))); + Tcl_IncrRefCount(root); return root; } @@ -1001,8 +1003,8 @@ Tcl_FSJoinPath( } /* - * This element is just what we want to return already - no - * further manipulation is requred. + * This element is just what we want to return already; no further + * manipulation is requred. */ return elt; @@ -1276,41 +1278,41 @@ TclNewFSPathObj( /* * Look for path components made up of only "." - * This is overly conservative analysis to keep simple. It may - * mark some things as needing more aggressive normalization - * that don't actually need it. No harm done. + * This is overly conservative analysis to keep simple. It may mark some + * things as needing more aggressive normalization that don't actually + * need it. No harm done. */ for (p = addStrRep; len > 0; p++, len--) { - switch (state) { - case 0: /* So far only "." since last dirsep or start */ - switch (*p) { - case '.': - count++; - break; - case '/': - case '\\': - case ':': - if (count) { - PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM; - len = 0; - } - break; - default: - count = 0; - state = 1; - } - case 1: /* Scanning for next dirsep */ - switch (*p) { - case '/': - case '\\': - case ':': - state = 0; - break; - } - } + switch (state) { + case 0: /* So far only "." since last dirsep or start */ + switch (*p) { + case '.': + count++; + break; + case '/': + case '\\': + case ':': + if (count) { + PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM; + len = 0; + } + break; + default: + count = 0; + state = 1; + } + case 1: /* Scanning for next dirsep */ + switch (*p) { + case '/': + case '\\': + case ':': + state = 0; + break; + } + } } if (len == 0 && count) { - PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM; + PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM; } return pathPtr; @@ -1647,8 +1649,9 @@ Tcl_FSGetTranslatedPath( Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp, srcFsPathPtr->cwdPtr); + retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1, - &(srcFsPathPtr->normPathPtr)); + &srcFsPathPtr->normPathPtr); srcFsPathPtr->translatedPathPtr = retObj; Tcl_IncrRefCount(retObj); Tcl_DecrRefCount(translatedCwdPtr); @@ -1704,7 +1707,7 @@ Tcl_FSGetTranslatedStringPath( if (transPtr != NULL) { int len; const char *orig = Tcl_GetStringFromObj(transPtr, &len); - char *result = (char *) ckalloc((unsigned) len+1); + char *result = ckalloc((unsigned) len+1); memcpy(result, orig, (size_t) len+1); TclDecrRefCount(transPtr); @@ -1752,8 +1755,7 @@ Tcl_FSGetNormalizedPath( */ Tcl_Obj *dir, *copy; - int cwdLen; - int pathType; + int cwdLen, pathType; const char *cwdStr; ClientData clientData = NULL; @@ -1801,25 +1803,25 @@ Tcl_FSGetNormalizedPath( if (PATHFLAGS(pathPtr) & TCLPATH_NEEDNORM) { /* - * If the "tail" part has components (like /../) that cause - * the combined path to need more complete normalizing, - * call on the more powerful routine to accomplish that so - * we avoid [Bug 2385549] ... + * If the "tail" part has components (like /../) that cause the + * combined path to need more complete normalizing, call on the + * more powerful routine to accomplish that so we avoid [Bug + * 2385549] ... */ Tcl_Obj *newCopy = TclFSNormalizeAbsolutePath(interp, copy, NULL); + Tcl_DecrRefCount(copy); copy = newCopy; } else { /* - * ... but in most cases where we join a trouble free tail - * to a normalized head, we can more efficiently normalize the - * combined path by passing over only the unnormalized tail - * portion. When this is sufficient, prior developers claim - * this should be much faster. We use 'cwdLen-1' so that we are - * already pointing at the dir-separator that we know about. - * The normalization code will actually start off directly - * after that separator. + * ... but in most cases where we join a trouble free tail to a + * normalized head, we can more efficiently normalize the combined + * path by passing over only the unnormalized tail portion. When + * this is sufficient, prior developers claim this should be much + * faster. We use 'cwdLen-1' so that we are already pointing at + * the dir-separator that we know about. The normalization code + * will actually start off directly after that separator. */ TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, @@ -1833,11 +1835,11 @@ Tcl_FSGetNormalizedPath( /* * NOTE: here we are (dangerously?) assuming that origDir points - * to a Tcl_Obj with Tcl_ObjType == &tclFsPathType . The + * to a Tcl_Obj with Tcl_ObjType == &tclFsPathType. The * pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); - * above that set the pathType value should have established - * that, but it's far less clear on what basis we know there's - * been no shimmering since then. + * above that set the pathType value should have established that, + * but it's far less clear on what basis we know there's been no + * shimmering since then. */ FsPath *origDirFsPathPtr = PATHOBJ(origDir); @@ -1869,9 +1871,10 @@ Tcl_FSGetNormalizedPath( if (clientData != NULL) { /* * This may be unnecessary. It appears that the - * TclFSNormalizeToUniquePath call above should have already - * set this up. Not changing out of fear of the unknown. + * TclFSNormalizeToUniquePath call above should have already set + * this up. Not changing out of fear of the unknown. */ + fsPathPtr->nativePathPtr = clientData; } PATHFLAGS(pathPtr) = 0; @@ -1950,6 +1953,7 @@ Tcl_FSGetNormalizedPath( Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr; const char *path = TclGetString(absolutePath); + Tcl_IncrRefCount(absolutePath); /* @@ -1961,17 +1965,17 @@ Tcl_FSGetNormalizedPath( if (path[0] == '\0') { /* - * Special handling for the empty string value. This one is - * very weird with [file normalize {}] => {}. (The reasoning - * supporting this is unknown to DGP, but he fears changing it.) - * Attempt here to keep the expectations of other parts of - * Tcl_Filesystem code about state of the FsPath fields satisfied. + * Special handling for the empty string value. This one is very + * weird with [file normalize {}] => {}. (The reasoning supporting + * this is unknown to DGP, but he fears changing it.) Attempt here + * to keep the expectations of other parts of Tcl_Filesystem code + * about state of the FsPath fields satisfied. * * In particular, capture the cwd value and save so it can be * stored in the cwdPtr field below. */ - useThisCwd = Tcl_FSGetCwd(interp); + useThisCwd = Tcl_FSGetCwd(interp); } else { /* * We don't ask for the type of 'pathPtr' here, because that is @@ -2024,7 +2028,7 @@ Tcl_FSGetNormalizedPath( (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); if (0 && (clientData != NULL)) { fsPathPtr->nativePathPtr = - fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc(clientData); + fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc(clientData); } /* @@ -2390,7 +2394,7 @@ SetFsPathFromAny( char *expandedUser; Tcl_DString temp; int split; - char separator='/'; + char separator = '/'; split = FindSplitPos(name, separator); if (split != len) { diff --git a/generic/tclPipe.c b/generic/tclPipe.c index be64e0b..b20ffe1 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPipe.c,v 1.20 2008/04/27 22:21:32 dkf Exp $ + * RCS: @(#) $Id: tclPipe.c,v 1.21 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -96,17 +96,17 @@ FileForRedirect( } *skipPtr = 2; } - chan = Tcl_GetChannel(interp, spec, NULL); - if (chan == (Tcl_Channel) NULL) { - return NULL; - } + chan = Tcl_GetChannel(interp, spec, NULL); + if (chan == (Tcl_Channel) NULL) { + return NULL; + } file = TclpMakeFile(chan, writing ? TCL_WRITABLE : TCL_READABLE); - if (file == NULL) { + if (file == NULL) { Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan), "\" wasn't opened for ", ((writing) ? "writing" : "reading"), NULL); - return NULL; - } + return NULL; + } *releasePtr = 1; if (writing) { /* @@ -114,7 +114,7 @@ FileForRedirect( * by the child appears after stuff we've already written. */ - Tcl_Flush(chan); + Tcl_Flush(chan); } } else { const char *name; @@ -139,7 +139,7 @@ FileForRedirect( Tcl_PosixError(interp), NULL); return NULL; } - *closePtr = 1; + *closePtr = 1; } return file; @@ -281,24 +281,24 @@ TclCleanupChildren( */ resolvedPid = TclpGetPid(pidPtr[i]); - pid = Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0); + pid = Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0); if (pid == (Tcl_Pid) -1) { result = TCL_ERROR; - if (interp != NULL) { - msg = Tcl_PosixError(interp); - if (errno == ECHILD) { + if (interp != NULL) { + msg = Tcl_PosixError(interp); + if (errno == ECHILD) { /* - * This changeup in message suggested by Mark Diekhans to - * remind people that ECHILD errors can occur on some - * systems if SIGCHLD isn't in its default state. - */ - - msg = - "child process lost (is SIGCHLD ignored or trapped?)"; - } - Tcl_AppendResult(interp, "error waiting for process to exit: ", - msg, NULL); - } + * This changeup in message suggested by Mark Diekhans to + * remind people that ECHILD errors can occur on some + * systems if SIGCHLD isn't in its default state. + */ + + msg = + "child process lost (is SIGCHLD ignored or trapped?)"; + } + Tcl_AppendResult(interp, "error waiting for process to exit: ", + msg, NULL); + } continue; } @@ -315,32 +315,32 @@ TclCleanupChildren( result = TCL_ERROR; sprintf(msg1, "%lu", resolvedPid); if (WIFEXITED(waitStatus)) { - if (interp != (Tcl_Interp *) NULL) { + if (interp != NULL) { sprintf(msg2, "%lu", (unsigned long) WEXITSTATUS(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL); - } + Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL); + } abnormalExit = 1; } else if (interp != NULL) { const char *p; if (WIFSIGNALED(waitStatus)) { - p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus))); - Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, - Tcl_SignalId((int) (WTERMSIG(waitStatus))), p, - NULL); - Tcl_AppendResult(interp, "child killed: ", p, "\n", NULL); + p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus))); + Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, + Tcl_SignalId((int) (WTERMSIG(waitStatus))), p, + NULL); + Tcl_AppendResult(interp, "child killed: ", p, "\n", NULL); } else if (WIFSTOPPED(waitStatus)) { - p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus))); - Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, - Tcl_SignalId((int) (WSTOPSIG(waitStatus))), p, + p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus))); + Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, + Tcl_SignalId((int) (WSTOPSIG(waitStatus))), p, + NULL); + Tcl_AppendResult(interp, "child suspended: ", p, "\n", NULL); - Tcl_AppendResult(interp, "child suspended: ", p, "\n", - NULL); } else { - Tcl_AppendResult(interp, - "child wait status didn't make sense\n", NULL); - } + Tcl_AppendResult(interp, + "child wait status didn't make sense\n", NULL); + } } } } @@ -356,7 +356,7 @@ TclCleanupChildren( * Make sure we start at the beginning of the file. */ - if (interp != NULL) { + if (interp != NULL) { int count; Tcl_Obj *objPtr; @@ -687,9 +687,12 @@ TclCreatePipeline( break; default: - /* Got a command word, not a redirection */ - needCmd = 0; - break; + /* + * Got a command word, not a redirection. + */ + + needCmd = 0; + break; } if (skip != 0) { @@ -702,11 +705,12 @@ TclCreatePipeline( } if (needCmd) { - /* We had a bar followed only by redirections. */ + /* + * We had a bar followed only by redirections. + */ - Tcl_SetResult(interp, - "illegal use of | or |& in command", - TCL_STATIC); + Tcl_SetResult(interp, "illegal use of | or |& in command", + TCL_STATIC); goto error; } @@ -1023,7 +1027,7 @@ TclCreatePipeline( Tcl_Channel Tcl_OpenCommandChannel( Tcl_Interp *interp, /* Interpreter for error reporting. Can NOT be - * NULL. */ + * NULL. */ int argc, /* How many arguments. */ const char **argv, /* Array of arguments for command pipe. */ int flags) /* Or'ed combination of TCL_STDIN, TCL_STDOUT, @@ -1042,7 +1046,7 @@ Tcl_OpenCommandChannel( errFilePtr = (flags & TCL_STDERR) ? &errFile : NULL; numPids = TclCreatePipeline(interp, argc, argv, &pidPtr, inPipePtr, - outPipePtr, errFilePtr); + outPipePtr, errFilePtr); if (numPids < 0) { goto error; @@ -1069,9 +1073,9 @@ Tcl_OpenCommandChannel( channel = TclpCreateCommandChannel(outPipe, inPipe, errFile, numPids, pidPtr); - if (channel == (Tcl_Channel) NULL) { - Tcl_AppendResult(interp, "pipe for command could not be created", - NULL); + if (channel == NULL) { + Tcl_AppendResult(interp, "pipe for command could not be created", + NULL); goto error; } return channel; diff --git a/generic/tclPosixStr.c b/generic/tclPosixStr.c index f1f72db..376815e 100644 --- a/generic/tclPosixStr.c +++ b/generic/tclPosixStr.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPosixStr.c,v 1.13 2008/04/27 22:21:32 dkf Exp $ + * RCS: @(#) $Id: tclPosixStr.c,v 1.14 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -61,7 +61,7 @@ Tcl_ErrnoId(void) #ifdef EALIGN case EALIGN: return "EALIGN"; #endif -#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) +#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY)) case EALREADY: return "EALREADY"; #endif #ifdef EBADE @@ -337,7 +337,7 @@ Tcl_ErrnoId(void) #if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP)) case EOPNOTSUPP: return "EOPNOTSUPP"; #endif -#if defined(EOVERFLOW) && ( !defined(EFBIG) || (EOVERFLOW != EFBIG) ) && ( !defined(EINVAL) || (EOVERFLOW != EINVAL) ) +#if defined(EOVERFLOW) && (!defined(EFBIG) || (EOVERFLOW != EFBIG)) && (!defined(EINVAL) || (EOVERFLOW != EINVAL)) case EOVERFLOW: return "EOVERFLOW"; #endif #ifdef EPERM @@ -508,7 +508,7 @@ Tcl_ErrnoMsg( #ifdef EALIGN case EALIGN: return "EALIGN"; #endif -#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) +#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY)) case EALREADY: return "operation already in progress"; #endif #ifdef EBADE @@ -651,7 +651,7 @@ Tcl_ErrnoMsg( #endif #ifdef ELIBMAX case ELIBMAX: return - "attempting to link in more shared libraries than system limit"; + "attempting to link in more shared libraries than system limit"; #endif #ifdef ELIBSCN case ELIBSCN: return ".lib section in a.out corrupted"; @@ -785,7 +785,7 @@ Tcl_ErrnoMsg( #if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP)) case EOPNOTSUPP: return "operation not supported on socket"; #endif -#if defined(EOVERFLOW) && ( !defined(EFBIG) || (EOVERFLOW != EFBIG) ) && ( !defined(EINVAL) || (EOVERFLOW != EINVAL) ) +#if defined(EOVERFLOW) && (!defined(EFBIG) || (EOVERFLOW != EFBIG)) && (!defined(EINVAL) || (EOVERFLOW != EINVAL)) case EOVERFLOW: return "file too big"; #endif #ifdef EPERM diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index 9cc79a5..f90e4bc 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPreserve.c,v 1.11 2008/10/26 18:34:04 dkf Exp $ + * RCS: @(#) $Id: tclPreserve.c,v 1.12 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -91,10 +91,10 @@ TclFinalizePreserve(void) { Tcl_MutexLock(&preserveMutex); if (spaceAvl != 0) { - ckfree((char *) refArray); - refArray = NULL; - inUse = 0; - spaceAvl = 0; + ckfree((char *) refArray); + refArray = NULL; + inUse = 0; + spaceAvl = 0; } Tcl_MutexUnlock(&preserveMutex); } @@ -280,13 +280,12 @@ Tcl_EventuallyFree( continue; } if (refPtr->mustFree) { - Tcl_Panic("Tcl_EventuallyFree called twice for 0x%x", - clientData); - } - refPtr->mustFree = 1; + Tcl_Panic("Tcl_EventuallyFree called twice for 0x%x", clientData); + } + refPtr->mustFree = 1; refPtr->freeProc = freeProc; Tcl_MutexUnlock(&preserveMutex); - return; + return; } Tcl_MutexUnlock(&preserveMutex); diff --git a/generic/tclProc.c b/generic/tclProc.c index 80c792c..99aee95 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.168 2008/12/02 19:40:41 dgp Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.169 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -75,9 +75,9 @@ const Tcl_ObjType tclProcBodyType = { }; /* - * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue field, - * encoding the type of level reference in ptr1 and the actual parsed out - * offset in ptr2. + * The [upvar]/[uplevel] level reference type. Uses the ptrAndLongRep field, + * encoding the type of level reference in ptr and the actual parsed out + * offset in value. * * Uses the default behaviour throughout, and never disposes of the string * rep; it's just a cache type. @@ -796,10 +796,10 @@ TclObjGetFrame( result = 1; curLevel = iPtr->varFramePtr->level; if (objPtr->typePtr == &levelReferenceType) { - if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr1)) { - level = curLevel - PTR2INT(objPtr->internalRep.twoPtrValue.ptr2); + if (objPtr->internalRep.ptrAndLongRep.ptr != NULL) { + level = curLevel - objPtr->internalRep.ptrAndLongRep.value; } else { - level = PTR2INT(objPtr->internalRep.twoPtrValue.ptr2); + level = objPtr->internalRep.ptrAndLongRep.value; } if (level < 0) { goto levelError; @@ -827,8 +827,8 @@ TclObjGetFrame( TclFreeIntRep(objPtr); objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.twoPtrValue.ptr1 = (void *) 0; - objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level); + objPtr->internalRep.ptrAndLongRep.ptr = NULL; + objPtr->internalRep.ptrAndLongRep.value = level; } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ if (Tcl_GetInt(interp, name, &level) != TCL_OK) { return -1; @@ -842,8 +842,8 @@ TclObjGetFrame( TclFreeIntRep(objPtr); objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.twoPtrValue.ptr1 = (void *) 1; - objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level); + objPtr->internalRep.ptrAndLongRep.ptr = (void *) 1; /* non-NULL */ + objPtr->internalRep.ptrAndLongRep.value = level; level = curLevel - level; } else { /* @@ -873,6 +873,7 @@ TclObjGetFrame( levelError: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL); return -1; } @@ -976,7 +977,7 @@ TclNRUplevelObjCmd( * TIP #280. Make actual argument location available to eval'd script */ - TclArgumentGet (interp, objv[0], &invoker, &word); + TclArgumentGet(interp, objv[0], &invoker, &word); objPtr = objv[0]; } else { diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 7664ebd..5db3d66 100755 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStrToD.c,v 1.36 2009/01/08 16:41:34 dkf Exp $ + * RCS: @(#) $Id: tclStrToD.c,v 1.37 2009/01/09 11:21:46 dkf Exp $ * *---------------------------------------------------------------------- */ @@ -1231,7 +1231,7 @@ AccumulateDecimalDigit( * number to a bignum and fall through into the bignum case. */ - TclBNInitBignumFromWideUInt (bignumRepPtr, w); + TclBNInitBignumFromWideUInt(bignumRepPtr, w); } else { /* * Wide multiplication. @@ -1694,8 +1694,8 @@ RefineApproximation( */ if (mp_cmp_mag(&twoMd, &twoMv) == MP_LT) { - mp_clear(&twoMd); - mp_clear(&twoMv); + mp_clear(&twoMd); + mp_clear(&twoMv); return approxResult; } diff --git a/generic/tclTest.c b/generic/tclTest.c index 3648f94..ebcdb97 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.134 2008/11/27 08:23:51 ferrieux Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.135 2009/01/09 11:21:46 dkf Exp $ */ #define TCL_TEST @@ -1188,7 +1188,7 @@ TestcmdtraceCmd( } else { return result; } - } else if ( strcmp(argv[1], "doubletest" ) == 0 ) { + } else if (strcmp(argv[1], "doubletest") == 0) { Tcl_Trace t1, t2; Tcl_DStringInit(&buffer); @@ -4330,7 +4330,7 @@ TestfeventCmd( * Calls the panic routine. * * Results: - * Always returns TCL_OK. + * Always returns TCL_OK. * * Side effects: * May exit application. @@ -4976,14 +4976,15 @@ TestmainthreadCmd( int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { - if (argc == 1) { - Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread()); - Tcl_SetObjResult(interp, idObj); - return TCL_OK; - } else { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); - return TCL_ERROR; - } + if (argc == 1) { + Tcl_Obj *idObj = Tcl_NewLongObj((long) Tcl_GetCurrentThread()); + + Tcl_SetObjResult(interp, idObj); + return TCL_OK; + } else { + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + return TCL_ERROR; + } } /* diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index c88a519..680dd18 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTestObj.c,v 1.27 2008/11/26 23:09:34 nijtmans Exp $ + * RCS: @(#) $Id: tclTestObj.c,v 1.28 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -85,7 +85,7 @@ TclObjTest_Init( register int i; for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { - varPtr[i] = NULL; + varPtr[i] = NULL; } Tcl_CreateObjCommand(interp, "testbignumobj", TestbignumobjCmd, @@ -130,14 +130,13 @@ TestbignumobjCmd( Tcl_Obj *const objv[]) /* Argument vector */ { const char *const subcmds[] = { - "set", "get", "mult10", "div10", NULL + "set", "get", "mult10", "div10", NULL }; enum options { - BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10 + BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10 }; - int index, varIndex; - char* string; + char *string; mp_int bignumValue, newValue; if (objc < 3) { @@ -438,9 +437,9 @@ TestdoubleobjCmd( return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue * 10.0)); + Tcl_SetDoubleObj(varPtr[varIndex], doubleValue * 10.0); } else { - SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue * 10.0) )); + SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue * 10.0)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "div10") == 0) { @@ -451,13 +450,13 @@ TestdoubleobjCmd( return TCL_ERROR; } if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex], - &doubleValue) != TCL_OK) { + &doubleValue) != TCL_OK) { return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue / 10.0)); + Tcl_SetDoubleObj(varPtr[varIndex], doubleValue / 10.0); } else { - SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue / 10.0) )); + SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue / 10.0)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { @@ -501,9 +500,9 @@ TestindexobjCmd( * Keep this structure declaration in sync with tclIndexObj.c */ struct IndexRep { - void *tablePtr; /* Pointer to the table of strings */ - int offset; /* Offset between table entries */ - int index; /* Selected index into table. */ + void *tablePtr; /* Pointer to the table of strings. */ + int offset; /* Offset between table entries. */ + int index; /* Selected index into table. */ }; struct IndexRep *indexRep; @@ -688,7 +687,7 @@ TestintobjCmd( return TCL_ERROR; } Tcl_AppendToObj(Tcl_GetObjResult(interp), - ((longValue == LONG_MAX)? "1" : "0"), -1); + ((longValue == LONG_MAX)? "1" : "0"), -1); } else if (strcmp(subCmd, "get") == 0) { if (objc != 3) { goto wrongNumArgs; @@ -740,13 +739,13 @@ TestintobjCmd( return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, varPtr[varIndex], - &intValue) != TCL_OK) { + &intValue) != TCL_OK) { return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], (intValue * 10)); + Tcl_SetIntObj(varPtr[varIndex], intValue * 10); } else { - SetVarToObj(varIndex, Tcl_NewIntObj( (intValue * 10) )); + SetVarToObj(varIndex, Tcl_NewIntObj(intValue * 10)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "div10") == 0) { @@ -757,13 +756,13 @@ TestintobjCmd( return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, varPtr[varIndex], - &intValue) != TCL_OK) { + &intValue) != TCL_OK) { return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], (intValue / 10)); + Tcl_SetIntObj(varPtr[varIndex], intValue / 10); } else { - SetVarToObj(varIndex, Tcl_NewIntObj( (intValue / 10) )); + SetVarToObj(varIndex, Tcl_NewIntObj(intValue / 10)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { @@ -811,106 +810,107 @@ TestobjCmd( subCmd = Tcl_GetString(objv[1]); if (strcmp(subCmd, "assign") == 0) { - if (objc != 4) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varIndex)) { + if (objc != 4) { + goto wrongNumArgs; + } + index = Tcl_GetString(objv[2]); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } string = Tcl_GetString(objv[3]); - if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { - return TCL_ERROR; - } - SetVarToObj(destIndex, varPtr[varIndex]); + if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { + return TCL_ERROR; + } + SetVarToObj(destIndex, varPtr[varIndex]); Tcl_SetObjResult(interp, varPtr[destIndex]); - } else if (strcmp(subCmd, "convert") == 0) { - char *typeName; - if (objc != 4) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varIndex)) { + } else if (strcmp(subCmd, "convert") == 0) { + char *typeName; + + if (objc != 4) { + goto wrongNumArgs; + } + index = Tcl_GetString(objv[2]); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } - typeName = Tcl_GetString(objv[3]); - if ((targetType = Tcl_GetObjType(typeName)) == NULL) { + typeName = Tcl_GetString(objv[3]); + if ((targetType = Tcl_GetObjType(typeName)) == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "no type ", typeName, " found", NULL); - return TCL_ERROR; - } - if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) - != TCL_OK) { - return TCL_ERROR; - } + return TCL_ERROR; + } + if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) + != TCL_OK) { + return TCL_ERROR; + } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "duplicate") == 0) { - if (objc != 4) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varIndex)) { + if (objc != 4) { + goto wrongNumArgs; + } + index = Tcl_GetString(objv[2]); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } string = Tcl_GetString(objv[3]); - if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { - return TCL_ERROR; - } - SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex])); + if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { + return TCL_ERROR; + } + SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex])); Tcl_SetObjResult(interp, varPtr[destIndex]); } else if (strcmp(subCmd, "freeallvars") == 0) { - if (objc != 2) { - goto wrongNumArgs; - } - for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { - if (varPtr[i] != NULL) { - Tcl_DecrRefCount(varPtr[i]); - varPtr[i] = NULL; - } - } - } else if ( strcmp ( subCmd, "invalidateStringRep" ) == 0 ) { - if ( objc != 3 ) { + if (objc != 2) { + goto wrongNumArgs; + } + for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { + if (varPtr[i] != NULL) { + Tcl_DecrRefCount(varPtr[i]); + varPtr[i] = NULL; + } + } + } else if (strcmp(subCmd, "invalidateStringRep") == 0) { + if (objc != 3) { goto wrongNumArgs; } - index = Tcl_GetString( objv[2] ); - if ( GetVariableIndex( interp, index, &varIndex ) != TCL_OK ) { + index = Tcl_GetString(objv[2]); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } - if (CheckIfVarUnset(interp, varIndex)) { + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } - Tcl_InvalidateStringRep( varPtr[varIndex] ); - Tcl_SetObjResult( interp, varPtr[varIndex] ); + Tcl_InvalidateStringRep(varPtr[varIndex]); + Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "newobj") == 0) { - if (objc != 3) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - SetVarToObj(varIndex, Tcl_NewObj()); + if (objc != 3) { + goto wrongNumArgs; + } + index = Tcl_GetString(objv[2]); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + SetVarToObj(varIndex, Tcl_NewObj()); Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "objtype") == 0) { const char *typeName; /* - * return an object containing the name of the argument's type - * of internal rep. If none exists, return "none". + * Return an object containing the name of the argument's type of + * internal rep. If none exists, return "none". */ - if (objc != 3) { - goto wrongNumArgs; - } + if (objc != 3) { + goto wrongNumArgs; + } if (objv[2]->typePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); } else { @@ -918,38 +918,38 @@ TestobjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); } } else if (strcmp(subCmd, "refcount") == 0) { - if (objc != 3) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varIndex)) { + if (objc != 3) { + goto wrongNumArgs; + } + index = Tcl_GetString(objv[2]); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount)); } else if (strcmp(subCmd, "type") == 0) { - if (objc != 3) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varIndex)) { + if (objc != 3) { + goto wrongNumArgs; + } + index = Tcl_GetString(objv[2]); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } - if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); - } else { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - varPtr[varIndex]->typePtr->name, -1); - } + } else { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + varPtr[varIndex]->typePtr->name, -1); + } } else if (strcmp(subCmd, "types") == 0) { - if (objc != 2) { - goto wrongNumArgs; - } + if (objc != 2) { + goto wrongNumArgs; + } if (Tcl_AppendAllObjTypes(interp, Tcl_GetObjResult(interp)) != TCL_OK) { return TCL_ERROR; diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index d346d59..234b267 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTestProcBodyObj.c,v 1.7 2008/07/13 09:03:35 msofer Exp $ + * RCS: @(#) $Id: tclTestProcBodyObj.c,v 1.8 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -33,8 +33,7 @@ static char procCommand[] = "proc"; * procs */ -typedef struct CmdTable -{ +typedef struct CmdTable { char *cmdName; /* command name */ Tcl_ObjCmdProc *proc; /* command proc */ int exportIt; /* if 1, export the command */ @@ -49,8 +48,8 @@ static int ProcBodyTestProcObjCmd(ClientData dummy, static int ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe); static int RegisterCommand(Tcl_Interp* interp, char *namespace, const CmdTable *cmdTablePtr); -int Procbodytest_Init(Tcl_Interp * interp); -int Procbodytest_SafeInit(Tcl_Interp * interp); +int Procbodytest_Init(Tcl_Interp * interp); +int Procbodytest_SafeInit(Tcl_Interp * interp); /* * List of commands to create when the package is loaded; must go after the @@ -72,13 +71,13 @@ static const CmdTable safeCommands[] = { * * Procbodytest_Init -- * - * This function initializes the "procbodytest" package. + * This function initializes the "procbodytest" package. * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ @@ -86,7 +85,7 @@ static const CmdTable safeCommands[] = { int Procbodytest_Init( Tcl_Interp *interp) /* the Tcl interpreter for which the package - * is initialized */ + * is initialized */ { return ProcBodyTestInitInternal(interp, 0); } @@ -96,13 +95,13 @@ Procbodytest_Init( * * Procbodytest_SafeInit -- * - * This function initializes the "procbodytest" package. + * This function initializes the "procbodytest" package. * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ @@ -110,7 +109,7 @@ Procbodytest_Init( int Procbodytest_SafeInit( Tcl_Interp *interp) /* the Tcl interpreter for which the package - * is initialized */ + * is initialized */ { return ProcBodyTestInitInternal(interp, 1); } @@ -120,36 +119,38 @@ Procbodytest_SafeInit( * * RegisterCommand -- * - * This function registers a command in the context of the given namespace. + * This function registers a command in the context of the given + * namespace. * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ -static int RegisterCommand(interp, namespace, cmdTablePtr) - Tcl_Interp* interp; /* the Tcl interpreter for which the operation +static int +RegisterCommand( + Tcl_Interp* interp, /* the Tcl interpreter for which the operation * is performed */ - char *namespace; /* the namespace in which the command is + char *namespace, /* the namespace in which the command is * registered */ - const CmdTable *cmdTablePtr;/* the command to register */ + const CmdTable *cmdTablePtr)/* the command to register */ { char buf[128]; if (cmdTablePtr->exportIt) { - sprintf(buf, "namespace eval %s { namespace export %s }", - namespace, cmdTablePtr->cmdName); - if (Tcl_Eval(interp, buf) != TCL_OK) - return TCL_ERROR; + sprintf(buf, "namespace eval %s { namespace export %s }", + namespace, cmdTablePtr->cmdName); + if (Tcl_Eval(interp, buf) != TCL_OK) { + return TCL_ERROR; + } } sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName); Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0); - return TCL_OK; } @@ -173,16 +174,16 @@ static int RegisterCommand(interp, namespace, cmdTablePtr) static int ProcBodyTestInitInternal( Tcl_Interp *interp, /* the Tcl interpreter for which the package - * is initialized */ + * is initialized */ int isSafe) /* 1 if this is a safe interpreter */ { const CmdTable *cmdTablePtr; cmdTablePtr = (isSafe) ? &safeCommands[0] : &commands[0]; for ( ; cmdTablePtr->cmdName ; cmdTablePtr++) { - if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) { - return TCL_ERROR; - } + if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) { + return TCL_ERROR; + } } return Tcl_PkgProvide(interp, packageName, packageVersion); @@ -248,7 +249,7 @@ ProcBodyTestProcObjCmd( fullName = Tcl_GetStringFromObj(objv[3], NULL); procCmd = Tcl_FindCommand(interp, fullName, NULL, TCL_LEAVE_ERR_MSG); if (procCmd == NULL) { - return TCL_ERROR; + return TCL_ERROR; } cmdPtr = (Command *) procCmd; @@ -259,9 +260,9 @@ ProcBodyTestProcObjCmd( */ if (cmdPtr->objClientData != TclIsProc(cmdPtr)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "command \"", fullName, "\" is not a Tcl procedure", NULL); - return TCL_ERROR; + return TCL_ERROR; } /* @@ -270,10 +271,9 @@ ProcBodyTestProcObjCmd( procPtr = (Proc *) cmdPtr->objClientData; if (procPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "procedure \"", fullName, - "\" does not have a Proc struct!", NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "procedure \"", + fullName, "\" does not have a Proc struct!", NULL); + return TCL_ERROR; } /* @@ -282,10 +282,10 @@ ProcBodyTestProcObjCmd( bodyObjPtr = TclNewProcBodyObj(procPtr); if (bodyObjPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "failed to create a procbody object for procedure \"", - fullName, "\"", NULL); - return TCL_ERROR; + fullName, "\"", NULL); + return TCL_ERROR; } Tcl_IncrRefCount(bodyObjPtr); diff --git a/generic/tclThread.c b/generic/tclThread.c index 0feba5b..7d5d4dd 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclThread.c,v 1.21 2008/07/24 21:54:39 nijtmans Exp $ + * RCS: @(#) $Id: tclThread.c,v 1.22 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -99,7 +99,7 @@ Tcl_GetThreadData( *keyPtr = result; RememberSyncObject((char *) keyPtr, &keyRecord); } else { - result = *keyPtr; + result = *keyPtr; } #endif /* TCL_THREADS */ return result; diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index a448328..ba30637 100755 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclThreadAlloc.c,v 1.28 2008/07/29 18:19:17 msofer Exp $ + * RCS: @(#) $Id: tclThreadAlloc.c,v 1.29 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -495,8 +495,8 @@ TclpRealloc( * list is empty. * * Note: - * If this code is updated, the changes need to be reflected in the - * macro TclAllocObjStorageEx() defined in tclInt.h + * If this code is updated, the changes need to be reflected in the macro + * TclAllocObjStorageEx() defined in tclInt.h * *---------------------------------------------------------------------- */ @@ -568,8 +568,8 @@ TclThreadAllocObj(void) * May move free Tcl_Obj's to shared list upon hitting high water mark. * * Note: - * If this code is updated, the changes need to be reflected in the - * macro TclAllocObjStorageEx() defined in tclInt.h + * If this code is updated, the changes need to be reflected in the macro + * TclAllocObjStorageEx() defined in tclInt.h * *---------------------------------------------------------------------- */ @@ -985,8 +985,8 @@ TclFinalizeThreadAlloc(void) unsigned int i; for (i = 0; i < NBUCKETS; ++i) { - TclpFreeAllocMutex(bucketInfo[i].lockPtr); - bucketInfo[i].lockPtr = NULL; + TclpFreeAllocMutex(bucketInfo[i].lockPtr); + bucketInfo[i].lockPtr = NULL; } TclpFreeAllocMutex(objLockPtr); diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index cad9e11..7ee5704 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclThreadTest.c,v 1.29 2008/12/16 23:24:13 nijtmans Exp $ + * RCS: @(#) $Id: tclThreadTest.c,v 1.30 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -32,11 +32,13 @@ extern int Tcltest_Init(Tcl_Interp *interp); */ typedef struct ThreadSpecificData { - Tcl_ThreadId threadId; /* Tcl ID for this thread */ - Tcl_Interp *interp; /* Main interpreter for this thread */ - int flags; /* See the TP_ defines below... */ - struct ThreadSpecificData *nextPtr; /* List for "thread names" */ - struct ThreadSpecificData *prevPtr; /* List for "thread names" */ + Tcl_ThreadId threadId; /* Tcl ID for this thread */ + Tcl_Interp *interp; /* Main interpreter for this thread */ + int flags; /* See the TP_ defines below... */ + struct ThreadSpecificData *nextPtr; + /* List for "thread names" */ + struct ThreadSpecificData *prevPtr; + /* List for "thread names" */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; @@ -51,7 +53,7 @@ static struct ThreadSpecificData *threadList; * The following bit-values are legal for the "flags" field of the * ThreadSpecificData structure. */ -#define TP_Dying 0x001 /* This thread is being canceled */ +#define TP_Dying 0x001 /* This thread is being canceled */ /* * An instance of the following structure contains all information that is @@ -153,7 +155,7 @@ static void ThreadExitProc(ClientData clientData); * Initialize the test thread command. * * Results: - * TCL_OK if the package was properly initialized. + * TCL_OK if the package was properly initialized. * * Side effects: * Add the "testthread" command to the interp. @@ -175,8 +177,7 @@ TclThread_Init( } Tcl_MutexUnlock(&threadMutex); - Tcl_CreateObjCommand(interp, "testthread", Tcl_ThreadObjCmd, - (ClientData) NULL, NULL); + Tcl_CreateObjCommand(interp, "testthread", Tcl_ThreadObjCmd, NULL, NULL); return TCL_OK; } @@ -299,9 +300,8 @@ Tcl_ThreadObjCmd( script = Tcl_GetStringFromObj(objv[2], &len); - if ((len > 1) && - (script [0] == '-') && (script [1] == 'j') && - (0 == strncmp (script, "-joinable", (size_t) len))) { + if ((len > 1) && (script[0] == '-') && (script[1] == 'j') && + (0 == strncmp(script, "-joinable", (size_t) len))) { joinable = 1; script = "testthread wait"; /* Just enter event loop */ } else { @@ -317,11 +317,8 @@ Tcl_ThreadObjCmd( */ script = Tcl_GetStringFromObj(objv[2], &len); - - joinable = ((len > 1) && - (script [0] == '-') && (script [1] == 'j') && - (0 == strncmp(script, "-joinable", (size_t) len))); - + joinable = ((len > 1) && (script[0] == '-') && (script[1] == 'j') + && (0 == strncmp(script, "-joinable", (size_t) len))); script = Tcl_GetString(objv[3]); } else { Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?"); @@ -345,17 +342,16 @@ Tcl_ThreadObjCmd( * Check if they want the main thread id or the current thread id. */ - if (objc == 2) { + if (objc == 2) { idObj = Tcl_NewLongObj((long) Tcl_GetCurrentThread()); + } else if (objc == 3 + && strcmp("-main", Tcl_GetString(objv[2])) == 0) { + Tcl_MutexLock(&threadMutex); + idObj = Tcl_NewLongObj((long) mainThreadId); + Tcl_MutexUnlock(&threadMutex); } else { - if (objc == 3 && strcmp("-main", Tcl_GetString(objv[2])) == 0) { - Tcl_MutexLock(&threadMutex); - idObj = Tcl_NewLongObj((long) mainThreadId); - Tcl_MutexUnlock(&threadMutex); - } else { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; } Tcl_SetObjResult(interp, idObj); @@ -376,11 +372,11 @@ Tcl_ThreadObjCmd( return TCL_ERROR; } - result = Tcl_JoinThread ((Tcl_ThreadId) id, &status); + result = Tcl_JoinThread((Tcl_ThreadId) id, &status); if (result == TCL_OK) { - Tcl_SetIntObj (Tcl_GetObjResult (interp), status); + Tcl_SetIntObj(Tcl_GetObjResult(interp), status); } else { - char buf [20]; + char buf[20]; sprintf(buf, "%ld", id); Tcl_AppendResult(interp, "cannot join thread ", buf, NULL); @@ -467,7 +463,8 @@ Tcl_ThreadObjCmd( * calling Tcl_Canceled to check if the command has been canceled. */ - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) { + if (Tcl_Canceled(interp, + TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) { break; } (void) Tcl_DoOneEvent(TCL_ALL_EVENTS); @@ -521,7 +518,7 @@ TclCreateThread( if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl, TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) { Tcl_MutexUnlock(&threadMutex); - Tcl_AppendResult(interp, "can't create a new thread", NULL); + Tcl_AppendResult(interp, "can't create a new thread", NULL); ckfree((char *) ctrl.script); return TCL_ERROR; } @@ -569,7 +566,7 @@ Tcl_ThreadCreateType NewTestThread( ClientData clientData) { - ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData; + ThreadCtrl *ctrlPtr = clientData; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); int result; char *threadEvalScript; @@ -604,7 +601,7 @@ NewTestThread( threadEvalScript = ckalloc(strlen(ctrlPtr->script)+1); strcpy(threadEvalScript, ctrlPtr->script); - Tcl_CreateThreadExitHandler(ThreadExitProc, (ClientData) threadEvalScript); + Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript); /* * Notify the parent we are alive. @@ -617,7 +614,7 @@ NewTestThread( * Run the script. */ - Tcl_Preserve((ClientData) tsdPtr->interp); + Tcl_Preserve(tsdPtr->interp); result = Tcl_Eval(tsdPtr->interp, threadEvalScript); if (result != TCL_OK) { ThreadErrorProc(tsdPtr->interp); @@ -628,7 +625,7 @@ NewTestThread( */ ListRemove(tsdPtr); - Tcl_Release((ClientData) tsdPtr->interp); + Tcl_Release(tsdPtr->interp); Tcl_DeleteInterp(tsdPtr->interp); Tcl_ExitThread(result); @@ -836,7 +833,7 @@ TclThreadSend( */ if (threadId == Tcl_GetCurrentThread()) { - Tcl_MutexUnlock(&threadMutex); + Tcl_MutexUnlock(&threadMutex); return Tcl_GlobalEval(interp, script); } @@ -883,7 +880,7 @@ TclThreadSend( */ threadEventPtr->event.proc = ThreadEventProc; - Tcl_ThreadQueueEvent(threadId, (Tcl_Event *)threadEventPtr, + Tcl_ThreadQueueEvent(threadId, (Tcl_Event *) threadEventPtr, TCL_QUEUE_TAIL); Tcl_ThreadAlert(threadId); @@ -898,7 +895,7 @@ TclThreadSend( Tcl_ResetResult(interp); while (resultPtr->result == NULL) { - Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL); + Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL); } /* @@ -1016,7 +1013,7 @@ ThreadEventProc( int mask) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr; + ThreadEvent *threadEventPtr = (ThreadEvent *) evPtr; ThreadEventResult *resultPtr = threadEventPtr->resultPtr; Tcl_Interp *interp = tsdPtr->interp; int code; @@ -1028,13 +1025,11 @@ ThreadEventProc( errorCode = "THREAD"; errorInfo = ""; } else { - Tcl_Preserve((ClientData) interp); + Tcl_Preserve(interp); Tcl_ResetResult(interp); - Tcl_CreateThreadExitHandler(ThreadFreeProc, - (ClientData) threadEventPtr->script); + Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script); code = Tcl_GlobalEval(interp, threadEventPtr->script); - Tcl_DeleteThreadExitHandler(ThreadFreeProc, - (ClientData) threadEventPtr->script); + Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script); if (code != TCL_OK) { errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); @@ -1061,7 +1056,7 @@ ThreadEventProc( Tcl_MutexUnlock(&threadMutex); } if (interp != NULL) { - Tcl_Release((ClientData) interp); + Tcl_Release(interp); } return 1; } @@ -1151,17 +1146,17 @@ static void ThreadExitProc( ClientData clientData) { - char *threadEvalScript = (char *) clientData; + char *threadEvalScript = clientData; ThreadEventResult *resultPtr, *nextPtr; Tcl_ThreadId self = Tcl_GetCurrentThread(); Tcl_MutexLock(&threadMutex); if (threadEvalScript) { - ckfree((char *) threadEvalScript); + ckfree(threadEvalScript); threadEvalScript = NULL; } - Tcl_DeleteEvents((Tcl_EventDeleteProc *)ThreadDeleteEvent, NULL); + Tcl_DeleteEvents((Tcl_EventDeleteProc *) ThreadDeleteEvent, NULL); for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) { nextPtr = resultPtr->nextPtr; diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 03e01fa..b970d50 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTimer.c,v 1.37 2008/12/09 20:16:30 dgp Exp $ + * RCS: @(#) $Id: tclTimer.c,v 1.38 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -74,7 +74,7 @@ typedef struct AfterAssocData { */ typedef struct IdleHandler { - Tcl_IdleProc (*proc); /* Function 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. */ @@ -297,7 +297,7 @@ TclCreateAbsoluteTimerHandler( * Fill in fields for the event. */ - memcpy((void *)&timerHandlerPtr->time, (void *)timePtr, sizeof(Tcl_Time)); + memcpy(&timerHandlerPtr->time, timePtr, sizeof(Tcl_Time)); timerHandlerPtr->proc = proc; timerHandlerPtr->clientData = clientData; tsdPtr->lastTimerId++; @@ -406,7 +406,6 @@ TimerSetupProc( blockTime.sec = 0; blockTime.usec = 0; - } else if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) { /* * Compute the timeout for the next timer on the list. @@ -807,8 +806,7 @@ Tcl_AfterObjCmd( assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData)); assocPtr->interp = interp; assocPtr->firstAfterPtr = NULL; - Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, - (ClientData) assocPtr); + Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr); } /* @@ -817,17 +815,16 @@ Tcl_AfterObjCmd( if (objv[1]->typePtr == &tclIntType #ifndef NO_WIDE_TYPE - || objv[1]->typePtr == &tclWideIntType + || objv[1]->typePtr == &tclWideIntType #endif - || objv[1]->typePtr == &tclBignumType - || ( Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, - &index) != TCL_OK )) { + || objv[1]->typePtr == &tclBignumType + || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, + &index) != TCL_OK)) { index = -1; if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { Tcl_AppendResult(interp, "bad argument \"", - Tcl_GetString(objv[1]), - "\": must be cancel, idle, info, or an integer", - NULL); + Tcl_GetString(objv[1]), + "\": must be cancel, idle, info, or an integer", NULL); return TCL_ERROR; } } @@ -873,8 +870,8 @@ Tcl_AfterObjCmd( wakeup.sec++; wakeup.usec -= 1000000; } - afterPtr->token = TclCreateAbsoluteTimerHandler(&wakeup, AfterProc, - (ClientData) afterPtr); + afterPtr->token = TclCreateAbsoluteTimerHandler(&wakeup, + AfterProc, afterPtr); afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id)); @@ -915,7 +912,7 @@ Tcl_AfterObjCmd( if (afterPtr->token != NULL) { Tcl_DeleteTimerHandler(afterPtr->token); } else { - Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); + Tcl_CancelIdleCall(AfterProc, afterPtr); } FreeAfterPtr(afterPtr); } @@ -939,7 +936,7 @@ Tcl_AfterObjCmd( afterPtr->token = NULL; afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; - Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); + Tcl_DoWhenIdle(AfterProc, afterPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id)); break; case AFTER_INFO: { @@ -1146,7 +1143,7 @@ static void AfterProc( ClientData clientData) /* Describes command to execute. */ { - AfterInfo *afterPtr = (AfterInfo *) clientData; + AfterInfo *afterPtr = clientData; AfterAssocData *assocPtr = afterPtr->assocPtr; AfterInfo *prevPtr; int result; @@ -1173,13 +1170,13 @@ AfterProc( */ interp = assocPtr->interp; - Tcl_Preserve((ClientData) interp); + Tcl_Preserve(interp); result = Tcl_EvalObjEx(interp, afterPtr->commandPtr, TCL_EVAL_GLOBAL); if (result != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (\"after\" script)"); Tcl_BackgroundException(interp, result); } - Tcl_Release((ClientData) interp); + Tcl_Release(interp); /* * Free the memory for the callback. @@ -1251,7 +1248,7 @@ AfterCleanupProc( * interpreter. */ Tcl_Interp *interp) /* Interpreter that is being deleted. */ { - AfterAssocData *assocPtr = (AfterAssocData *) clientData; + AfterAssocData *assocPtr = clientData; AfterInfo *afterPtr; while (assocPtr->firstAfterPtr != NULL) { @@ -1260,7 +1257,7 @@ AfterCleanupProc( if (afterPtr->token != NULL) { Tcl_DeleteTimerHandler(afterPtr->token); } else { - Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); + Tcl_CancelIdleCall(AfterProc, afterPtr); } Tcl_DecrRefCount(afterPtr->commandPtr); ckfree((char *) afterPtr); diff --git a/generic/tclVar.c b/generic/tclVar.c index dad0d1a..6c5e382 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.174 2009/01/08 16:41:34 dkf Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.175 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -147,7 +147,7 @@ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr); static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr, Var *varPtr, int flags); -static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, +static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, Tcl_Obj *namePtr, Tcl_Namespace *contextNsPtr, int flags); static int ObjMakeUpvar(Tcl_Interp *interp, @@ -187,7 +187,7 @@ static Tcl_SetFromAnyProc PanicOnSetVarName; * * localVarName - INTERNALREP DEFINITION: * ptrAndLongRep.ptr: pointer to name obj in varFramePtr->localCache - * or NULL if it is this same obj + * or NULL if it is this same obj * ptrAndLongRep.value: index into locals table * * nsVarName - INTERNALREP DEFINITION: @@ -545,8 +545,7 @@ TclObjLookupVarEx( * Use the cached index if the names coincide. */ - Tcl_Obj *namePtr = (Tcl_Obj *) - part1Ptr->internalRep.ptrAndLongRep.ptr; + Tcl_Obj *namePtr = part1Ptr->internalRep.ptrAndLongRep.ptr; Tcl_Obj *checkNamePtr = localName(iPtr->varFramePtr, localIndex); if ((!namePtr && (checkNamePtr == part1Ptr)) || @@ -660,8 +659,8 @@ TclObjLookupVarEx( len2 = len1 - i - 2; len1 = i; - newPart2 = ckalloc((unsigned int) (len2+1)); - memcpy(newPart2, part2, (unsigned int) len2); + newPart2 = ckalloc((unsigned) (len2+1)); + memcpy(newPart2, part2, (unsigned) len2); *(newPart2+len2) = '\0'; part2 = newPart2; part2Ptr = Tcl_NewStringObj(newPart2, -1); @@ -4704,7 +4703,7 @@ PanicOnSetVarName( * * INTERNALREP DEFINITION: * ptrAndLongRep.ptr: pointer to name obj in varFramePtr->localCache - * or NULL if it is this same obj + * or NULL if it is this same obj * ptrAndLongRep.value: index into locals table */ @@ -4712,7 +4711,8 @@ static void FreeLocalVarName( Tcl_Obj *objPtr) { - Tcl_Obj *namePtr = (Tcl_Obj *) objPtr->internalRep.ptrAndLongRep.ptr; + Tcl_Obj *namePtr = objPtr->internalRep.ptrAndLongRep.ptr; + if (namePtr) { Tcl_DecrRefCount(namePtr); } @@ -5349,7 +5349,7 @@ TclInfoLocalsCmd( return TCL_ERROR; } - if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC )) { + if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)) { return TCL_OK; } diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index c902a28..d1bab28 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMacOSXFCmd.c,v 1.15 2008/10/26 18:50:06 dkf Exp $ + * RCS: @(#) $Id: tclMacOSXFCmd.c,v 1.16 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -27,19 +27,22 @@ #if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1040 /* Support for weakly importing copyfile. */ #define WEAK_IMPORT_COPYFILE -extern int copyfile(const char *from, const char *to, copyfile_state_t state, - copyfile_flags_t flags) WEAK_IMPORT_ATTRIBUTE; +extern int copyfile(const char *from, const char *to, + copyfile_state_t state, copyfile_flags_t flags) + WEAK_IMPORT_ATTRIBUTE; #endif /* HAVE_WEAK_IMPORT */ #else /* HAVE_COPYFILE_H */ -int copyfile(const char *from, const char *to, void *state, uint32_t flags); +int copyfile(const char *from, const char *to, + void *state, uint32_t flags); #define COPYFILE_ACL (1<<0) #define COPYFILE_XATTR (1<<2) #define COPYFILE_NOFOLLOW_SRC (1<<18) #if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1040 /* Support for weakly importing copyfile. */ #define WEAK_IMPORT_COPYFILE -extern int copyfile(const char *from, const char *to, void *state, - uint32_t flags) WEAK_IMPORT_ATTRIBUTE; +extern int copyfile(const char *from, const char *to, + void *state, uint32_t flags) + WEAK_IMPORT_ATTRIBUTE; #endif /* HAVE_WEAK_IMPORT */ #endif /* HAVE_COPYFILE_H */ #endif /* HAVE_COPYFILE */ @@ -391,75 +394,75 @@ TclMacOSXCopyFileAttributes( if (copyfile != NULL) { #endif #ifdef HAVE_COPYFILE - if (copyfile(src, dst, NULL, COPYFILE_XATTR | - (S_ISLNK(statBufPtr->st_mode) ? COPYFILE_NOFOLLOW_SRC : - COPYFILE_ACL)) < 0) { - return TCL_ERROR; - } - return TCL_OK; + if (copyfile(src, dst, NULL, COPYFILE_XATTR | + (S_ISLNK(statBufPtr->st_mode) + ? COPYFILE_NOFOLLOW_SRC : COPYFILE_ACL)) < 0) { + return TCL_ERROR; + } + return TCL_OK; #endif /* HAVE_COPYFILE */ #ifdef WEAK_IMPORT_COPYFILE } else { #endif #if !defined(HAVE_COPYFILE) || defined(WEAK_IMPORT_COPYFILE) #ifdef HAVE_GETATTRLIST - struct attrlist alist; - fileinfobuf finfo; - off_t *rsrcForkSize = (off_t *) &finfo.data; - - bzero(&alist, sizeof(struct attrlist)); - alist.bitmapcount = ATTR_BIT_MAP_COUNT; - alist.commonattr = ATTR_CMN_FNDRINFO; - - if (getattrlist(src, &alist, &finfo, sizeof(fileinfobuf), 0)) { - return TCL_ERROR; - } + struct attrlist alist; + fileinfobuf finfo; + off_t *rsrcForkSize = (off_t *) &finfo.data; - if (setattrlist(dst, &alist, &finfo.data, sizeof(finfo.data), 0)) { - return TCL_ERROR; - } - - if (!S_ISDIR(statBufPtr->st_mode)) { - /* - * Only copy non-empty resource fork. - */ - - alist.commonattr = 0; - alist.fileattr = ATTR_FILE_RSRCLENGTH; + bzero(&alist, sizeof(struct attrlist)); + alist.bitmapcount = ATTR_BIT_MAP_COUNT; + alist.commonattr = ATTR_CMN_FNDRINFO; if (getattrlist(src, &alist, &finfo, sizeof(fileinfobuf), 0)) { return TCL_ERROR; } - if(*rsrcForkSize > 0) { - int result; - Tcl_DString ds_src, ds_dst; + if (setattrlist(dst, &alist, &finfo.data, sizeof(finfo.data), 0)) { + return TCL_ERROR; + } + if (!S_ISDIR(statBufPtr->st_mode)) { /* - * Construct paths to resource forks. + * Only copy non-empty resource fork. */ - Tcl_DStringInit(&ds_src); - Tcl_DStringAppend(&ds_src, src, -1); - Tcl_DStringAppend(&ds_src, _PATH_RSRCFORKSPEC, -1); - Tcl_DStringInit(&ds_dst); - Tcl_DStringAppend(&ds_dst, dst, -1); - Tcl_DStringAppend(&ds_dst, _PATH_RSRCFORKSPEC, -1); + alist.commonattr = 0; + alist.fileattr = ATTR_FILE_RSRCLENGTH; - result = TclUnixCopyFile(Tcl_DStringValue(&ds_src), - Tcl_DStringValue(&ds_dst), statBufPtr, 1); + if (getattrlist(src, &alist, &finfo, sizeof(fileinfobuf), 0)) { + return TCL_ERROR; + } - Tcl_DStringFree(&ds_src); - Tcl_DStringFree(&ds_dst); + if (*rsrcForkSize > 0) { + int result; + Tcl_DString ds_src, ds_dst; - if (result != 0) { - return TCL_ERROR; + /* + * Construct paths to resource forks. + */ + + Tcl_DStringInit(&ds_src); + Tcl_DStringAppend(&ds_src, src, -1); + Tcl_DStringAppend(&ds_src, _PATH_RSRCFORKSPEC, -1); + Tcl_DStringInit(&ds_dst); + Tcl_DStringAppend(&ds_dst, dst, -1); + Tcl_DStringAppend(&ds_dst, _PATH_RSRCFORKSPEC, -1); + + result = TclUnixCopyFile(Tcl_DStringValue(&ds_src), + Tcl_DStringValue(&ds_dst), statBufPtr, 1); + + Tcl_DStringFree(&ds_src); + Tcl_DStringFree(&ds_dst); + + if (result != 0) { + return TCL_ERROR; + } } } - } - return TCL_OK; + return TCL_OK; #else - return TCL_ERROR; + return TCL_ERROR; #endif /* HAVE_GETATTRLIST */ #endif /* !defined(HAVE_COPYFILE) || defined(WEAK_IMPORT_COPYFILE) */ #ifdef WEAK_IMPORT_COPYFILE @@ -472,13 +475,13 @@ TclMacOSXCopyFileAttributes( * * TclMacOSXMatchType -- * - * This routine is used by the globbing code to check if a file - * matches a given mac type and/or creator code. + * This routine is used by the globbing code to check if a file matches a + * given mac type and/or creator code. * * Results: - * The return value is 1, 0 or -1 indicating whether the file - * matches the given criteria, does not match them, or an error - * occurred (in wich case an error is left in interp). + * The return value is 1, 0 or -1 indicating whether the file matches the + * given criteria, does not match them, or an error occurred (in wich + * case an error is left in interp). * * Side effects: * None. @@ -510,8 +513,12 @@ TclMacOSXMatchType( !((finder->fdFlags & kFinfoIsInvisible) || (*fileName == '.'))) { return 0; } - if (S_ISDIR(statBufPtr->st_mode) && (types->macType || types->macCreator)) { - /* Directories don't support types or creators */ + if (S_ISDIR(statBufPtr->st_mode) + && (types->macType || types->macCreator)) { + /* + * Directories don't support types or creators. + */ + return 0; } if (types->macType) { @@ -584,7 +591,8 @@ GetOSTypeFromObj( static Tcl_Obj * NewOSTypeObj( - const OSType osType) /* OSType used to initialize the new object. */ + const OSType osType) /* OSType used to initialize the new + * object. */ { Tcl_Obj *objPtr; @@ -631,8 +639,8 @@ SetOSTypeFromAny( } else { OSType osType; char string[4] = {'\0','\0','\0','\0'}; - memcpy(string, Tcl_DStringValue(&ds), - (size_t) Tcl_DStringLength(&ds)); + + memcpy(string, Tcl_DStringValue(&ds), (size_t)Tcl_DStringLength(&ds)); osType = (OSType) string[0] << 24 | (OSType) string[1] << 16 | (OSType) string[2] << 8 | diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index b67ef3e..8edbda2 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMacOSXNotify.c,v 1.21 2008/10/26 18:50:07 dkf Exp $ + * RCS: @(#) $Id: tclMacOSXNotify.c,v 1.22 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -239,7 +239,7 @@ static OSSpinLock notifierLock = SPINLOCK_INIT; * Debug version of SpinLockLock that logs the time spent waiting for the lock */ -#define SpinLockLockDbg(p) if(!SpinLockTry(p)) { \ +#define SpinLockLockDbg(p) if (!SpinLockTry(p)) { \ Tcl_WideInt s = TclpGetWideClicks(), e; \ SpinLockLock(p); e = TclpGetWideClicks(); \ fprintf(notifierLog, "tclMacOSXNotify.c:" \ @@ -313,8 +313,8 @@ static void AtForkChild(void); #if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1040 /* Support for weakly importing pthread_atfork. */ #define WEAK_IMPORT_PTHREAD_ATFORK -extern int pthread_atfork(void (*prepare)(void), void (*parent)(void), - void (*child)(void)) WEAK_IMPORT_ATTRIBUTE; +extern int pthread_atfork(void (*prepare)(void), void (*parent)(void), + void (*child)(void)) WEAK_IMPORT_ATTRIBUTE; #endif /* HAVE_WEAK_IMPORT */ /* * On Darwin 9 and later, it is not possible to call CoreFoundation after @@ -348,113 +348,112 @@ MODULE_SCOPE long tclMacOSXDarwinRelease; ClientData Tcl_InitNotifier(void) { + ThreadSpecificData *tsdPtr; + if (tclNotifierHooks.initNotifierProc) { return tclNotifierHooks.initNotifierProc(); - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + } - tsdPtr->eventReady = 0; + tsdPtr = TCL_TSD_INIT(&dataKey); + tsdPtr->eventReady = 0; #ifdef WEAK_IMPORT_SPINLOCKLOCK - /* - * Initialize support for weakly imported spinlock API. - */ - if (pthread_once(&spinLockLockInitControl, SpinLockLockInit)) { - Tcl_Panic("Tcl_InitNotifier: pthread_once failed"); - } + /* + * Initialize support for weakly imported spinlock API. + */ + + if (pthread_once(&spinLockLockInitControl, SpinLockLockInit)) { + Tcl_Panic("Tcl_InitNotifier: pthread_once failed"); + } #endif #ifndef __CONSTANT_CFSTRINGS__ - if (!tclEventsOnlyRunLoopMode) { - tclEventsOnlyRunLoopMode = CFSTR(TCL_EVENTS_ONLY_RUN_LOOP_MODE); - } + if (!tclEventsOnlyRunLoopMode) { + tclEventsOnlyRunLoopMode = CFSTR(TCL_EVENTS_ONLY_RUN_LOOP_MODE); + } #endif - /* - * Initialize CFRunLoopSource and add it to CFRunLoop of this thread. - */ + /* + * Initialize CFRunLoopSource and add it to CFRunLoop of this thread. + */ - if (!tsdPtr->runLoop) { - CFRunLoopRef runLoop = CFRunLoopGetCurrent(); - CFRunLoopSourceRef runLoopSource; - CFRunLoopSourceContext runLoopSourceContext; - - bzero(&runLoopSourceContext, sizeof(CFRunLoopSourceContext)); - runLoopSourceContext.info = tsdPtr; - runLoopSource = CFRunLoopSourceCreate(NULL, 0, - &runLoopSourceContext); - if (!runLoopSource) { - Tcl_Panic("Tcl_InitNotifier: could not create CFRunLoopSource"); - } - CFRunLoopAddSource(runLoop, runLoopSource, kCFRunLoopCommonModes); - CFRunLoopAddSource(runLoop, runLoopSource, - tclEventsOnlyRunLoopMode); - tsdPtr->runLoopSource = runLoopSource; - tsdPtr->runLoop = runLoop; + if (!tsdPtr->runLoop) { + CFRunLoopRef runLoop = CFRunLoopGetCurrent(); + CFRunLoopSourceRef runLoopSource; + CFRunLoopSourceContext runLoopSourceContext; + + bzero(&runLoopSourceContext, sizeof(CFRunLoopSourceContext)); + runLoopSourceContext.info = tsdPtr; + runLoopSource = CFRunLoopSourceCreate(NULL, 0, &runLoopSourceContext); + if (!runLoopSource) { + Tcl_Panic("Tcl_InitNotifier: could not create CFRunLoopSource"); } + CFRunLoopAddSource(runLoop, runLoopSource, kCFRunLoopCommonModes); + CFRunLoopAddSource(runLoop, runLoopSource, tclEventsOnlyRunLoopMode); + tsdPtr->runLoopSource = runLoopSource; + tsdPtr->runLoop = runLoop; + } - LOCK_NOTIFIER_INIT; + LOCK_NOTIFIER_INIT; #ifdef HAVE_PTHREAD_ATFORK - /* - * Install pthread_atfork handlers to reinitialize the notifier in the - * child of a fork. - */ + /* + * Install pthread_atfork handlers to reinitialize the notifier in the + * child of a fork. + */ - if ( + if ( #ifdef WEAK_IMPORT_PTHREAD_ATFORK - pthread_atfork != NULL && + pthread_atfork != NULL && #endif - !atForkInit) { - int result = pthread_atfork(AtForkPrepare, AtForkParent, - AtForkChild); + !atForkInit) { + int result = pthread_atfork(AtForkPrepare, AtForkParent, AtForkChild); - if (result) { - Tcl_Panic("Tcl_InitNotifier: pthread_atfork failed"); - } - atForkInit = 1; + if (result) { + Tcl_Panic("Tcl_InitNotifier: pthread_atfork failed"); } + atForkInit = 1; + } #endif - if (notifierCount == 0) { - int fds[2], status; + if (notifierCount == 0) { + int fds[2], status; - /* - * Initialize trigger pipe. - */ + /* + * Initialize trigger pipe. + */ - if (pipe(fds) != 0) { - Tcl_Panic("Tcl_InitNotifier: could not create trigger pipe"); - } + if (pipe(fds) != 0) { + Tcl_Panic("Tcl_InitNotifier: could not create trigger pipe"); + } - status = fcntl(fds[0], F_GETFL); - status |= O_NONBLOCK; - if (fcntl(fds[0], F_SETFL, status) < 0) { - Tcl_Panic("Tcl_InitNotifier: could not make receive pipe non blocking"); - } - status = fcntl(fds[1], F_GETFL); - status |= O_NONBLOCK; - if (fcntl(fds[1], F_SETFL, status) < 0) { - Tcl_Panic("Tcl_InitNotifier: could not make trigger pipe non blocking"); - } + status = fcntl(fds[0], F_GETFL); + status |= O_NONBLOCK; + if (fcntl(fds[0], F_SETFL, status) < 0) { + Tcl_Panic("Tcl_InitNotifier: could not make receive pipe non blocking"); + } + status = fcntl(fds[1], F_GETFL); + status |= O_NONBLOCK; + if (fcntl(fds[1], F_SETFL, status) < 0) { + Tcl_Panic("Tcl_InitNotifier: could not make trigger pipe non blocking"); + } - receivePipe = fds[0]; - triggerPipe = fds[1]; + receivePipe = fds[0]; + triggerPipe = fds[1]; - /* - * Create notifier thread lazily in Tcl_WaitForEvent() to avoid - * interfering with fork() followed immediately by execve() - * (cannot execve() when more than one thread is present). - */ + /* + * Create notifier thread lazily in Tcl_WaitForEvent() to avoid + * interfering with fork() followed immediately by execve() (we cannot + * execve() when more than one thread is present). + */ - notifierThread = 0; + notifierThread = 0; #ifdef TCL_MAC_DEBUG_NOTIFIER - OPEN_NOTIFIER_LOG; + OPEN_NOTIFIER_LOG; #endif - } - notifierCount++; - UNLOCK_NOTIFIER_INIT; - - return (ClientData) tsdPtr; } + notifierCount++; + UNLOCK_NOTIFIER_INIT; + + return (ClientData) tsdPtr; } /* @@ -479,71 +478,72 @@ void Tcl_FinalizeNotifier( ClientData clientData) /* Not used. */ { + ThreadSpecificData *tsdPtr; + if (tclNotifierHooks.finalizeNotifierProc) { tclNotifierHooks.finalizeNotifierProc(clientData); return; - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + } - LOCK_NOTIFIER_INIT; - notifierCount--; + tsdPtr = TCL_TSD_INIT(&dataKey); + LOCK_NOTIFIER_INIT; + notifierCount--; - /* - * If this is the last thread to use the notifier, close the notifier - * pipe and wait for the background thread to terminate. - */ + /* + * If this is the last thread to use the notifier, close the notifier pipe + * and wait for the background thread to terminate. + */ - if (notifierCount == 0) { - int result; + if (notifierCount == 0) { + int result; - if (triggerPipe < 0) { - Tcl_Panic("Tcl_FinalizeNotifier: notifier pipe not initialized"); - } + if (triggerPipe < 0) { + Tcl_Panic("Tcl_FinalizeNotifier: notifier pipe not initialized"); + } - /* - * Send "q" message to the notifier thread so that it will - * terminate. The notifier will return from its call to select() - * and notice that a "q" message has arrived, it will then close - * its side of the pipe and terminate its thread. Note the we can - * not just close the pipe and check for EOF in the notifier thread - * because if a background child process was created with exec, - * select() would not register the EOF on the pipe until the child - * processes had terminated. [Bug: 4139] [Bug: 1222872] - */ + /* + * Send "q" message to the notifier thread so that it will terminate. + * The notifier will return from its call to select() and notice that + * a "q" message has arrived, it will then close its side of the pipe + * and terminate its thread. Note the we can not just close the pipe + * and check for EOF in the notifier thread because if a background + * child process was created with exec, select() would not register + * the EOF on the pipe until the child processes had terminated. [Bug: + * 4139] [Bug: 1222872] + */ - write(triggerPipe, "q", 1); - close(triggerPipe); + write(triggerPipe, "q", 1); + close(triggerPipe); - if (notifierThread) { - result = pthread_join(notifierThread, NULL); - if (result) { - Tcl_Panic("Tcl_FinalizeNotifier: unable to join notifier thread"); - } - notifierThread = 0; + if (notifierThread) { + result = pthread_join(notifierThread, NULL); + if (result) { + Tcl_Panic("Tcl_FinalizeNotifier: unable to join notifier thread"); } + notifierThread = 0; + } - close(receivePipe); - triggerPipe = -1; + close(receivePipe); + triggerPipe = -1; #ifdef TCL_MAC_DEBUG_NOTIFIER - CLOSE_NOTIFIER_LOG; + CLOSE_NOTIFIER_LOG; #endif - } - UNLOCK_NOTIFIER_INIT; + } + UNLOCK_NOTIFIER_INIT; - LOCK_NOTIFIER; /* for concurrency with Tcl_AlertNotifier */ - if (tsdPtr->runLoop) { - tsdPtr->runLoop = NULL; + LOCK_NOTIFIER; /* For concurrency with Tcl_AlertNotifier */ + if (tsdPtr->runLoop) { + tsdPtr->runLoop = NULL; - /* - * Remove runLoopSource from all CFRunLoops and release it. - */ + /* + * Remove runLoopSource from all CFRunLoops and release it. + */ - CFRunLoopSourceInvalidate(tsdPtr->runLoopSource); - CFRelease(tsdPtr->runLoopSource); - tsdPtr->runLoopSource = NULL; - } - UNLOCK_NOTIFIER; + CFRunLoopSourceInvalidate(tsdPtr->runLoopSource); + CFRelease(tsdPtr->runLoopSource); + tsdPtr->runLoopSource = NULL; } + UNLOCK_NOTIFIER; } /* @@ -569,20 +569,20 @@ void Tcl_AlertNotifier( ClientData clientData) { + ThreadSpecificData *tsdPtr = clientData; + if (tclNotifierHooks.alertNotifierProc) { tclNotifierHooks.alertNotifierProc(clientData); return; - } else { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; + } - LOCK_NOTIFIER; - if (tsdPtr->runLoop) { - tsdPtr->eventReady = 1; - CFRunLoopSourceSignal(tsdPtr->runLoopSource); - CFRunLoopWakeUp(tsdPtr->runLoop); - } - UNLOCK_NOTIFIER; + LOCK_NOTIFIER; + if (tsdPtr->runLoop) { + tsdPtr->eventReady = 1; + CFRunLoopSourceSignal(tsdPtr->runLoopSource); + CFRunLoopWakeUp(tsdPtr->runLoop); } + UNLOCK_NOTIFIER; } /* @@ -610,13 +610,13 @@ Tcl_SetTimer( if (tclNotifierHooks.setTimerProc) { tclNotifierHooks.setTimerProc(timePtr); return; - } else { - /* - * The interval timer doesn't do anything in this implementation, - * because the only event loop is via Tcl_DoOneEvent, which passes - * timeout values to Tcl_WaitForEvent. - */ } + + /* + * The interval timer doesn't do anything in this implementation, because + * the only event loop is via Tcl_DoOneEvent, which passes timeout values + * to Tcl_WaitForEvent. + */ } /* @@ -675,52 +675,54 @@ Tcl_CreateFileHandler( * event. */ ClientData clientData) /* Arbitrary data to pass to proc. */ { + ThreadSpecificData *tsdPtr; + FileHandler *filePtr; + if (tclNotifierHooks.createFileHandlerProc) { tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData); return; - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - FileHandler *filePtr; + } - for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->fd == fd) { - break; - } - } - if (filePtr == NULL) { - filePtr = (FileHandler*) ckalloc(sizeof(FileHandler)); - filePtr->fd = fd; - filePtr->readyMask = 0; - filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; - tsdPtr->firstFileHandlerPtr = filePtr; + tsdPtr = TCL_TSD_INIT(&dataKey); + + for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->fd == fd) { + break; } - filePtr->proc = proc; - filePtr->clientData = clientData; - filePtr->mask = mask; + } + if (filePtr == NULL) { + filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); + filePtr->fd = fd; + filePtr->readyMask = 0; + filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; + tsdPtr->firstFileHandlerPtr = filePtr; + } + filePtr->proc = proc; + filePtr->clientData = clientData; + filePtr->mask = mask; - /* - * Update the check masks for this file. - */ + /* + * Update the check masks for this file. + */ - if (mask & TCL_READABLE) { - FD_SET(fd, &(tsdPtr->checkMasks.readable)); - } else { - FD_CLR(fd, &(tsdPtr->checkMasks.readable)); - } - if (mask & TCL_WRITABLE) { - FD_SET(fd, &(tsdPtr->checkMasks.writable)); - } else { - FD_CLR(fd, &(tsdPtr->checkMasks.writable)); - } - if (mask & TCL_EXCEPTION) { - FD_SET(fd, &(tsdPtr->checkMasks.exceptional)); - } else { - FD_CLR(fd, &(tsdPtr->checkMasks.exceptional)); - } - if (tsdPtr->numFdBits <= fd) { - tsdPtr->numFdBits = fd+1; - } + if (mask & TCL_READABLE) { + FD_SET(fd, &(tsdPtr->checkMasks.readable)); + } else { + FD_CLR(fd, &(tsdPtr->checkMasks.readable)); + } + if (mask & TCL_WRITABLE) { + FD_SET(fd, &(tsdPtr->checkMasks.writable)); + } else { + FD_CLR(fd, &(tsdPtr->checkMasks.writable)); + } + if (mask & TCL_EXCEPTION) { + FD_SET(fd, &(tsdPtr->checkMasks.exceptional)); + } else { + FD_CLR(fd, &(tsdPtr->checkMasks.exceptional)); + } + if (tsdPtr->numFdBits <= fd) { + tsdPtr->numFdBits = fd+1; } } @@ -745,69 +747,71 @@ Tcl_DeleteFileHandler( int fd) /* Stream id for which to remove callback * function. */ { + FileHandler *filePtr, *prevPtr; + int i; + ThreadSpecificData *tsdPtr; + if (tclNotifierHooks.deleteFileHandlerProc) { tclNotifierHooks.deleteFileHandlerProc(fd); return; - } else { - FileHandler *filePtr, *prevPtr; - int i; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * Find the entry for the given file (and return if there isn't one). - */ + } - for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; - prevPtr = filePtr, filePtr = filePtr->nextPtr) { - if (filePtr == NULL) { - return; - } - if (filePtr->fd == fd) { - break; - } - } + tsdPtr = TCL_TSD_INIT(&dataKey); - /* - * Update the check masks for this file. - */ + /* + * Find the entry for the given file (and return if there isn't one). + */ - if (filePtr->mask & TCL_READABLE) { - FD_CLR(fd, &(tsdPtr->checkMasks.readable)); - } - if (filePtr->mask & TCL_WRITABLE) { - FD_CLR(fd, &(tsdPtr->checkMasks.writable)); + for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; + prevPtr = filePtr, filePtr = filePtr->nextPtr) { + if (filePtr == NULL) { + return; } - if (filePtr->mask & TCL_EXCEPTION) { - FD_CLR(fd, &(tsdPtr->checkMasks.exceptional)); + if (filePtr->fd == fd) { + break; } + } - /* - * Find current max fd. - */ + /* + * Update the check masks for this file. + */ - if (fd+1 == tsdPtr->numFdBits) { - tsdPtr->numFdBits = 0; - for (i = fd-1; i >= 0; i--) { - if (FD_ISSET(i, &(tsdPtr->checkMasks.readable)) - || FD_ISSET(i, &(tsdPtr->checkMasks.writable)) - || FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))) { - tsdPtr->numFdBits = i+1; - break; - } + if (filePtr->mask & TCL_READABLE) { + FD_CLR(fd, &(tsdPtr->checkMasks.readable)); + } + if (filePtr->mask & TCL_WRITABLE) { + FD_CLR(fd, &(tsdPtr->checkMasks.writable)); + } + if (filePtr->mask & TCL_EXCEPTION) { + FD_CLR(fd, &(tsdPtr->checkMasks.exceptional)); + } + + /* + * Find current max fd. + */ + + if (fd+1 == tsdPtr->numFdBits) { + tsdPtr->numFdBits = 0; + for (i = fd-1; i >= 0; i--) { + if (FD_ISSET(i, &(tsdPtr->checkMasks.readable)) + || FD_ISSET(i, &(tsdPtr->checkMasks.writable)) + || FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))) { + tsdPtr->numFdBits = i+1; + break; } } + } - /* - * Clean up information in the callback record. - */ + /* + * Clean up information in the callback record. + */ - if (prevPtr == NULL) { - tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; - } else { - prevPtr->nextPtr = filePtr->nextPtr; - } - ckfree((char *) filePtr); + if (prevPtr == NULL) { + tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; + } else { + prevPtr->nextPtr = filePtr->nextPtr; } + ckfree((char *) filePtr); } /* @@ -905,203 +909,202 @@ int Tcl_WaitForEvent( const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { + FileHandler *filePtr; + FileHandlerEvent *fileEvPtr; + int mask, waitForFiles; + Tcl_Time myTime, *myTimePtr; + ThreadSpecificData *tsdPtr; + if (tclNotifierHooks.waitForEventProc) { return tclNotifierHooks.waitForEventProc(timePtr); - } else { - FileHandler *filePtr; - FileHandlerEvent *fileEvPtr; - int mask; - Tcl_Time myTime; - int waitForFiles; - Tcl_Time *myTimePtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + } + + tsdPtr = TCL_TSD_INIT(&dataKey); + /* + * Set up the timeout structure. Note that if there are no events to check + * for, we return with a negative result rather than blocking forever. + */ + + if (timePtr != NULL) { /* - * Set up the timeout structure. Note that if there are no events to - * check for, we return with a negative result rather than blocking - * forever. + * TIP #233 (Virtualized Time). Is virtual time in effect? And do we + * actually have something to scale? If yes to both then we call the + * handler to do this scaling. */ - if (timePtr != NULL) { - /* - * TIP #233 (Virtualized Time). Is virtual time in effect? And do - * we actually have something to scale? If yes to both then we call - * the handler to do this scaling. - */ + myTime.sec = timePtr->sec; + myTime.usec = timePtr->usec; - myTime.sec = timePtr->sec; - myTime.usec = timePtr->usec; + if (myTime.sec != 0 || myTime.usec != 0) { + tclScaleTimeProcPtr(&myTime, tclTimeClientData); + } - if (myTime.sec != 0 || myTime.usec != 0) { - tclScaleTimeProcPtr(&myTime, tclTimeClientData); - } + myTimePtr = &myTime; + } else { + myTimePtr = NULL; + } - myTimePtr = &myTime; - } else { - myTimePtr = NULL; + /* + * Start notifier thread if necessary. + */ + + LOCK_NOTIFIER_INIT; + if (!notifierCount) { + Tcl_Panic("Tcl_WaitForEvent: notifier not initialized"); + } + if (!notifierThread) { + int result; + pthread_attr_t attr; + + pthread_attr_init(&attr); + pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM); + pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_JOINABLE); + pthread_attr_setstacksize(&attr, 60 * 1024); + result = pthread_create(¬ifierThread, &attr, + (void * (*)(void *))NotifierThreadProc, NULL); + pthread_attr_destroy(&attr); + if (result || !notifierThread) { + Tcl_Panic("Tcl_WaitForEvent: unable to start notifier thread"); } + } + UNLOCK_NOTIFIER_INIT; + + /* + * Place this thread on the list of interested threads, signal the + * notifier thread, and wait for a response or a timeout. + */ + LOCK_NOTIFIER; + if (!tsdPtr->runLoop) { + Tcl_Panic("Tcl_WaitForEvent: CFRunLoop not initialized"); + } + waitForFiles = (tsdPtr->numFdBits > 0); + if (myTimePtr != NULL && myTimePtr->sec == 0 && myTimePtr->usec == 0) { /* - * Start notifier thread if necessary. + * Cannot emulate a polling select with a polling condition variable. + * Instead, pretend to wait for files and tell the notifier thread + * what we are doing. The notifier thread makes sure it goes through + * select with its select mask in the same state as ours currently is. + * We block until that happens. */ - LOCK_NOTIFIER_INIT; - if (!notifierCount) { - Tcl_Panic("Tcl_WaitForEvent: notifier not initialized"); - } - if (!notifierThread) { - int result; - pthread_attr_t attr; - - pthread_attr_init(&attr); - pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM); - pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_JOINABLE); - pthread_attr_setstacksize(&attr, 60 * 1024); - result = pthread_create(¬ifierThread, &attr, - (void * (*)(void *))NotifierThreadProc, NULL); - pthread_attr_destroy(&attr); - if (result || !notifierThread) { - Tcl_Panic("Tcl_WaitForEvent: unable to start notifier thread"); - } - } - UNLOCK_NOTIFIER_INIT; + waitForFiles = 1; + tsdPtr->pollState = POLL_WANT; + myTimePtr = NULL; + } else { + tsdPtr->pollState = 0; + } + if (waitForFiles) { /* - * Place this thread on the list of interested threads, signal the - * notifier thread, and wait for a response or a timeout. + * Add the ThreadSpecificData structure of this thread to the list of + * ThreadSpecificData structures of all threads that are waiting on + * file events. */ - LOCK_NOTIFIER; - if (!tsdPtr->runLoop) { - Tcl_Panic("Tcl_WaitForEvent: CFRunLoop not initialized"); - } - waitForFiles = (tsdPtr->numFdBits > 0); - if (myTimePtr != NULL && myTimePtr->sec == 0 && myTimePtr->usec == 0) { - /* - * Cannot emulate a polling select with a polling condition - * variable. Instead, pretend to wait for files and tell the - * notifier thread what we are doing. The notifier thread makes - * sure it goes through select with its select mask in the same - * state as ours currently is. We block until that happens. - */ - - waitForFiles = 1; - tsdPtr->pollState = POLL_WANT; - myTimePtr = NULL; - } else { - tsdPtr->pollState = 0; + tsdPtr->nextPtr = waitingListPtr; + if (waitingListPtr) { + waitingListPtr->prevPtr = tsdPtr; } + tsdPtr->prevPtr = 0; + waitingListPtr = tsdPtr; + tsdPtr->onList = 1; - if (waitForFiles) { - /* - * Add the ThreadSpecificData structure of this thread to the list - * of ThreadSpecificData structures of all threads that are waiting - * on file events. - */ - - tsdPtr->nextPtr = waitingListPtr; - if (waitingListPtr) { - waitingListPtr->prevPtr = tsdPtr; - } - tsdPtr->prevPtr = 0; - waitingListPtr = tsdPtr; - tsdPtr->onList = 1; - - write(triggerPipe, "", 1); - } + write(triggerPipe, "", 1); + } - FD_ZERO(&(tsdPtr->readyMasks.readable)); - FD_ZERO(&(tsdPtr->readyMasks.writable)); - FD_ZERO(&(tsdPtr->readyMasks.exceptional)); + FD_ZERO(&(tsdPtr->readyMasks.readable)); + FD_ZERO(&(tsdPtr->readyMasks.writable)); + FD_ZERO(&(tsdPtr->readyMasks.exceptional)); - if (!tsdPtr->eventReady) { - CFTimeInterval waitTime; - CFStringRef runLoopMode; + if (!tsdPtr->eventReady) { + CFTimeInterval waitTime; + CFStringRef runLoopMode; - if (myTimePtr == NULL) { - waitTime = 1.0e10; /* Wait forever, as per CFRunLoop.c */ - } else { - waitTime = myTimePtr->sec + 1.0e-6 * myTimePtr->usec; - } - /* - * If the run loop is already running (e.g. if Tcl_WaitForEvent was - * called recursively), re-run it in a custom run loop mode - * containing only the source for the notifier thread, otherwise - * wakeups from other sources added to the common run loop modes - * might get lost. - */ - if ((runLoopMode = CFRunLoopCopyCurrentMode(tsdPtr->runLoop))) { - CFRelease(runLoopMode); - runLoopMode = tclEventsOnlyRunLoopMode; - } else { - runLoopMode = kCFRunLoopDefaultMode; - } - UNLOCK_NOTIFIER; - CFRunLoopRunInMode(runLoopMode, waitTime, TRUE); - LOCK_NOTIFIER; + if (myTimePtr == NULL) { + waitTime = 1.0e10; /* Wait forever, as per CFRunLoop.c */ + } else { + waitTime = myTimePtr->sec + 1.0e-6 * myTimePtr->usec; } - tsdPtr->eventReady = 0; - if (waitForFiles && tsdPtr->onList) { - /* - * Remove the ThreadSpecificData structure of this thread from the - * waiting list. Alert the notifier thread to recompute its select - * masks - skipping this caused a hang when trying to close a pipe - * which the notifier thread was still doing a select on. - */ + /* + * If the run loop is already running (e.g. if Tcl_WaitForEvent was + * called recursively), re-run it in a custom run loop mode containing + * only the source for the notifier thread, otherwise wakeups from + * other sources added to the common run loop modes might get lost. + */ - if (tsdPtr->prevPtr) { - tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; - } else { - waitingListPtr = tsdPtr->nextPtr; - } - if (tsdPtr->nextPtr) { - tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; - } - tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; - tsdPtr->onList = 0; - write(triggerPipe, "", 1); + if ((runLoopMode = CFRunLoopCopyCurrentMode(tsdPtr->runLoop))) { + CFRelease(runLoopMode); + runLoopMode = tclEventsOnlyRunLoopMode; + } else { + runLoopMode = kCFRunLoopDefaultMode; } + UNLOCK_NOTIFIER; + CFRunLoopRunInMode(runLoopMode, waitTime, TRUE); + LOCK_NOTIFIER; + } + tsdPtr->eventReady = 0; + if (waitForFiles && tsdPtr->onList) { /* - * Queue all detected file events before returning. + * Remove the ThreadSpecificData structure of this thread from the + * waiting list. Alert the notifier thread to recompute its select + * masks; skipping this caused a hang when trying to close a pipe + * which the notifier thread was still doing a select on. */ - for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL); - filePtr = filePtr->nextPtr) { + if (tsdPtr->prevPtr) { + tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; + } else { + waitingListPtr = tsdPtr->nextPtr; + } + if (tsdPtr->nextPtr) { + tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; + } + tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; + tsdPtr->onList = 0; + write(triggerPipe, "", 1); + } - mask = 0; - if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.readable))) { - mask |= TCL_READABLE; - } - if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.writable))) { - mask |= TCL_WRITABLE; - } - if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.exceptional))) { - mask |= TCL_EXCEPTION; - } + /* + * Queue all detected file events before returning. + */ - if (!mask) { - continue; - } + for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL); + filePtr = filePtr->nextPtr) { + mask = 0; + if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.readable))) { + mask |= TCL_READABLE; + } + if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.writable))) { + mask |= TCL_WRITABLE; + } + if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.exceptional))) { + mask |= TCL_EXCEPTION; + } - /* - * Don't bother to queue an event if the mask was previously - * non-zero since an event must still be on the queue. - */ + if (!mask) { + continue; + } - if (filePtr->readyMask == 0) { - fileEvPtr = (FileHandlerEvent *) - ckalloc(sizeof(FileHandlerEvent)); - fileEvPtr->header.proc = FileHandlerEventProc; - fileEvPtr->fd = filePtr->fd; - Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); - } - filePtr->readyMask = mask; + /* + * Don't bother to queue an event if the mask was previously non-zero + * since an event must still be on the queue. + */ + + if (filePtr->readyMask == 0) { + fileEvPtr = (FileHandlerEvent *) + ckalloc(sizeof(FileHandlerEvent)); + fileEvPtr->header.proc = FileHandlerEventProc; + fileEvPtr->fd = filePtr->fd; + Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); } - UNLOCK_NOTIFIER; - return 0; + filePtr->readyMask = mask; } + UNLOCK_NOTIFIER; + return 0; } /* @@ -1233,9 +1236,9 @@ NotifierThreadProc( if (tsdPtr->onList) { /* * Remove the ThreadSpecificData structure of this thread - * from the waiting list. This prevents us from - * continuously spining on select until the other threads - * runs and services the file event. + * from the waiting list. This prevents us from spinning + * continuously on select until the other threads runs and + * services the file event. */ if (tsdPtr->prevPtr) { diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 3123ac0..e61f17d 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -6,7 +6,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixCompat.c,v 1.15 2008/02/28 20:14:12 jenglish Exp $ + * RCS: @(#) $Id: tclUnixCompat.c,v 1.16 2009/01/09 11:21:46 dkf Exp $ * */ @@ -70,10 +70,10 @@ TclUnixSetBlockingMode( * 'length' stay aligned. */ -#define PadBuffer(buffer, length, size) \ - if (((length) % (size))) { \ - (buffer) += ((size) - ((length) % (size))); \ - (length) += ((size) - ((length) % (size))); \ +#define PadBuffer(buffer, length, size) \ + if (((length) % (size))) { \ + (buffer) += ((size) - ((length) % (size))); \ + (length) += ((size) - ((length) % (size))); \ } /* diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 03c0cd6..2df4d2a 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -7,7 +7,7 @@ * Copyright (c) 1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclUnixInit.c,v 1.85 2008/09/25 14:30:21 dkf Exp $ + * RCS: @(#) $Id: tclUnixInit.c,v 1.86 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -18,7 +18,7 @@ # ifdef __APPLE__ # if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1030 /* Support for weakly importing nl_langinfo on Darwin. */ -# define WEAK_IMPORT_NL_LANGINFO +# define WEAK_IMPORT_NL_LANGINFO extern char *nl_langinfo(nl_item) WEAK_IMPORT_ATTRIBUTE; # endif # endif diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 4050d12..0d92556 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixPipe.c,v 1.47 2008/12/18 07:50:54 ferrieux Exp $ + * RCS: @(#) $Id: tclUnixPipe.c,v 1.48 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -87,7 +87,7 @@ static Tcl_ChannelType pipeChannelType = { NULL, /* handler proc. */ NULL, /* wide seek proc */ NULL, /* thread action proc */ - NULL, /* truncation */ + NULL, /* truncation */ }; /* diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index b5ff0c4..916a18c 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixTest.c,v 1.30 2008/12/20 01:03:32 das Exp $ + * RCS: @(#) $Id: tclUnixTest.c,v 1.31 2009/01/09 11:21:46 dkf Exp $ */ #include "tclInt.h" @@ -107,21 +107,21 @@ TclplatformtestInit( Tcl_CreateCommand(interp, "testchmod", TestchmodCmd, (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd, - (ClientData) 0, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd, - (ClientData) 0, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd, - (ClientData) 0, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd, - (ClientData) 0, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd, - (ClientData) 0, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testsetdefenc", TestsetdefencdirCmd, - (ClientData) 0, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testalarm", TestalarmCmd, - (ClientData) 0, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testgotsig", TestgotsigCmd, - (ClientData) 0, NULL); + (ClientData) 0, NULL); return TCL_OK; } @@ -169,7 +169,7 @@ TestfilehandlerCmd( if (argc < 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " option ... \"", NULL); + " option ... \"", NULL); return TCL_ERROR; } pipePtr = NULL; @@ -196,7 +196,7 @@ TestfilehandlerCmd( } else if (strcmp(argv[1], "clear") == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " clear index\"", NULL); + argv[0], " clear index\"", NULL); return TCL_ERROR; } pipePtr->readCount = pipePtr->writeCount = 0; @@ -205,7 +205,7 @@ TestfilehandlerCmd( if (argc != 3) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " counts index\"", NULL); + argv[0], " counts index\"", NULL); return TCL_ERROR; } sprintf(buf, "%d %d", pipePtr->readCount, pipePtr->writeCount); @@ -213,7 +213,7 @@ TestfilehandlerCmd( } else if (strcmp(argv[1], "create") == 0) { if (argc != 5) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " create index readMode writeMode\"", NULL); + argv[0], " create index readMode writeMode\"", NULL); return TCL_ERROR; } if (pipePtr->readFile == NULL) { @@ -261,30 +261,30 @@ TestfilehandlerCmd( } else if (strcmp(argv[1], "empty") == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " empty index\"", NULL); + argv[0], " empty index\"", NULL); return TCL_ERROR; } while (read(GetFd(pipePtr->readFile), buffer, 4000) > 0) { - /* Empty loop body. */ + /* Empty loop body. */ } } else if (strcmp(argv[1], "fill") == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " fill index\"", NULL); + argv[0], " fill index\"", NULL); return TCL_ERROR; } memset(buffer, 'a', 4000); while (write(GetFd(pipePtr->writeFile), buffer, 4000) > 0) { - /* Empty loop body. */ + /* Empty loop body. */ } } else if (strcmp(argv[1], "fillpartial") == 0) { char buf[TCL_INTEGER_SPACE]; if (argc != 3) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " fillpartial index\"", NULL); + argv[0], " fillpartial index\"", NULL); return TCL_ERROR; } @@ -296,7 +296,7 @@ TestfilehandlerCmd( } else if (strcmp(argv[1], "wait") == 0) { if (argc != 5) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " wait index readable|writable timeout\"", NULL); + argv[0], " wait index readable|writable timeout\"", NULL); return TCL_ERROR; } if (pipePtr->readFile == NULL) { @@ -487,16 +487,16 @@ TestgetopenfileCmd( if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName forWriting\"", NULL); + " channelName forWriting\"", NULL); return TCL_ERROR; } if (Tcl_GetOpenFile(interp, argv[1], atoi(argv[2]), 1, &filePtr) - == TCL_ERROR) { + == TCL_ERROR) { return TCL_ERROR; } if (filePtr == (ClientData) NULL) { Tcl_AppendResult(interp, - "Tcl_GetOpenFile succeeded but FILE * NULL!", NULL); + "Tcl_GetOpenFile succeeded but FILE * NULL!", NULL); return TCL_ERROR; } return TCL_OK; @@ -528,7 +528,7 @@ TestsetdefencdirCmd( { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " defaultDir\"", NULL); + " defaultDir\"", NULL); return TCL_ERROR; } diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c index 1150fee..eb800fb 100644 --- a/unix/tclXtTest.c +++ b/unix/tclXtTest.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclXtTest.c,v 1.7 2008/04/27 22:21:35 dkf Exp $ + * RCS: @(#) $Id: tclXtTest.c,v 1.8 2009/01/09 11:21:46 dkf Exp $ */ #include <X11/Intrinsic.h> @@ -47,7 +47,7 @@ Tclxttest_Init( XtToolkitInitialize(); InitNotifier(); Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd, - (ClientData) 0, NULL); + (ClientData) 0, NULL); return TCL_OK; } @@ -82,7 +82,7 @@ TesteventloopCmd( if (argc < 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " option ... \"", NULL); + " option ... \"", NULL); return TCL_ERROR; } if (strcmp(argv[1], "done") == 0) { diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 05263d1..b5e5729 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAppInit.c,v 1.26 2008/04/27 22:21:35 dkf Exp $ + * RCS: @(#) $Id: tclAppInit.c,v 1.27 2009/01/09 11:21:46 dkf Exp $ */ #include "tcl.h" @@ -81,7 +81,7 @@ main( */ #if defined(__GNUC__) - setargv( &argc, &argv ); + setargv(&argc, &argv); #endif setlocale(LC_ALL, "C"); diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 62a538b..e4850b0 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinThrd.c,v 1.49 2008/10/13 22:51:31 patthoyts Exp $ + * RCS: @(#) $Id: tclWinThrd.c,v 1.50 2009/01/09 11:21:46 dkf Exp $ */ #include "tclWinInt.h" @@ -496,6 +496,7 @@ Tcl_MutexLock( Tcl_Mutex *mutexPtr) /* The lock */ { CRITICAL_SECTION *csPtr; + if (*mutexPtr == NULL) { MASTER_LOCK; @@ -536,6 +537,7 @@ Tcl_MutexUnlock( Tcl_Mutex *mutexPtr) /* The lock */ { CRITICAL_SECTION *csPtr = *((CRITICAL_SECTION **)mutexPtr); + LeaveCriticalSection(csPtr); } @@ -561,6 +563,7 @@ TclpFinalizeMutex( Tcl_Mutex *mutexPtr) { CRITICAL_SECTION *csPtr = *(CRITICAL_SECTION **)mutexPtr; + if (csPtr != NULL) { DeleteCriticalSection(csPtr); ckfree((char *) csPtr); @@ -633,8 +636,7 @@ Tcl_ConditionWait( * and initializing that may drop back into the Master Lock. */ - Tcl_CreateThreadExitHandler(FinalizeConditionEvent, - (ClientData) tsdPtr); + Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr); } } @@ -646,11 +648,11 @@ Tcl_ConditionWait( */ if (*condPtr == NULL) { - winCondPtr = (WinCondition *)ckalloc(sizeof(WinCondition)); + winCondPtr = (WinCondition *) ckalloc(sizeof(WinCondition)); InitializeCriticalSection(&winCondPtr->condLock); winCondPtr->firstPtr = NULL; winCondPtr->lastPtr = NULL; - *condPtr = (Tcl_Condition)winCondPtr; + *condPtr = (Tcl_Condition) winCondPtr; TclRememberCondition(condPtr); } MASTER_UNLOCK; @@ -695,7 +697,8 @@ Tcl_ConditionWait( while (!timeout && (tsdPtr->flags & WIN_THREAD_BLOCKED)) { ResetEvent(tsdPtr->condEvent); LeaveCriticalSection(&winCondPtr->condLock); - if (WaitForSingleObjectEx(tsdPtr->condEvent, wtime, TRUE) == WAIT_TIMEOUT) { + if (WaitForSingleObjectEx(tsdPtr->condEvent, wtime, + TRUE) == WAIT_TIMEOUT) { timeout = 1; } EnterCriticalSection(&winCondPtr->condLock); @@ -760,6 +763,7 @@ Tcl_ConditionNotify( { WinCondition *winCondPtr; ThreadSpecificData *tsdPtr; + if (*condPtr != NULL) { winCondPtr = *((WinCondition **)condPtr); @@ -816,6 +820,7 @@ FinalizeConditionEvent( ClientData data) { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) data; + tsdPtr->flags = WIN_THREAD_UNINIT; CloseHandle(tsdPtr->condEvent); } @@ -964,7 +969,9 @@ TclpFreeAllocCache( #endif /* USE_THREAD_ALLOC */ -void *TclpThreadCreateKey (void) { +void * +TclpThreadCreateKey(void) +{ DWORD *key; key = TclpSysAlloc(sizeof *key, 0); @@ -981,7 +988,10 @@ void *TclpThreadCreateKey (void) { return key; } -void TclpThreadDeleteKey(void *keyPtr) { +void +TclpThreadDeleteKey( + void *keyPtr) +{ DWORD *key = keyPtr; if (!TlsFree(*key)) { @@ -991,7 +1001,11 @@ void TclpThreadDeleteKey(void *keyPtr) { TclpSysFree(keyPtr); } -void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr) { +void +TclpThreadSetMasterTSD( + void *tsdKeyPtr, + void *ptr) +{ DWORD *key = tsdKeyPtr; if (!TlsSetValue(*key, ptr)) { @@ -999,7 +1013,10 @@ void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr) { } } -void *TclpThreadGetMasterTSD(void *tsdKeyPtr) { +void * +TclpThreadGetMasterTSD( + void *tsdKeyPtr) +{ DWORD *key = tsdKeyPtr; return TlsGetValue(*key); |