From e4d2d840caacfcedda56ea4fbfcea4e0e1f306ab Mon Sep 17 00:00:00 2001 From: Steve Bennett Date: Sun, 24 Jan 2010 11:46:39 +1000 Subject: Source cleanups, typos, add test --- jim.c | 219 ++++++++++++++---------- tcltests/test_clientserver.tcl | 4 +- tcltests/test_eventloop.tcl | 2 +- test.tcl | 8 +- tests/concat.test | 32 ++++ tests/misc.test | 10 ++ tests/perf.test | 4 +- tests/proc.test | 379 +++++++++++++++++++++++++++++++++++++++++ 8 files changed, 562 insertions(+), 96 deletions(-) create mode 100644 tests/concat.test create mode 100644 tests/proc.test diff --git a/jim.c b/jim.c index 2f62276..8c27a73 100644 --- a/jim.c +++ b/jim.c @@ -45,10 +45,6 @@ #define __JIM_CORE__ #define JIM_OPTIMIZATION /* comment to avoid optimizations and reduce size */ -#ifdef __ECOS -#include -#endif - #ifndef JIM_ANSIC #define JIM_DYNLIB /* Dynamic library support */ #endif /* JIM_ANSIC */ @@ -324,7 +320,7 @@ int Jim_StringToWide(const char *str, jim_wide *widePtr, int base) return JIM_ERR; if (endptr[0] != '\0') { while(*endptr) { - if (!isspace((int)*endptr)) + if (!isspace(*endptr)) return JIM_ERR; endptr++; } @@ -341,7 +337,7 @@ int Jim_StringToIndex(const char *str, int *intPtr) return JIM_ERR; if (endptr[0] != '\0') { while(*endptr) { - if (!isspace((int)*endptr)) + if (!isspace(*endptr)) return JIM_ERR; endptr++; } @@ -367,32 +363,24 @@ static int JimFormatReference(char *buf, Jim_Reference *refPtr, jim_wide id) int Jim_DoubleToString(char *buf, double doubleValue) { - char *s; int len; - int hase = 0; len = sprintf(buf, "%.12g", doubleValue); - s = buf; - while(*s) { - if (*s == '.') return len; - if (*s == 'e') hase = 1; - s++; - } - if (hase) { - return len; - } /* Add a final ".0" if it's a number. But not * for NaN or InF */ - if (isdigit((int)buf[0]) - || ((buf[0] == '-' || buf[0] == '+') - && isdigit((int)buf[1]))) { - s[0] = '.'; - s[1] = '0'; - s[2] = '\0'; - return len+2; + while (*buf) { + if (*buf == '.' || isalpha(*buf)) { + return len; + } + buf++; } - return len; + + *buf++ = '.'; + *buf++ = '0'; + *buf = '\0'; + + return len + 2; } int Jim_StringToDouble(const char *str, double *doublePtr) @@ -442,9 +430,9 @@ void Jim_Panic(Jim_Interp *interp, const char *fmt, ...) size = backtrace(array, 40); strings = backtrace_symbols(array, size); for (i = 0; i < size; i++) - fprintf(fp,"[backtrace] %s" JIM_NL, strings[i]); - fprintf(fp,"[backtrace] Include the above lines and the output" JIM_NL); - fprintf(fp,"[backtrace] of 'nm ' in the bug report." JIM_NL); + fprintf(stderr,"[backtrace] %s" JIM_NL, strings[i]); + fprintf(stderr,"[backtrace] Include the above lines and the output" JIM_NL); + fprintf(stderr,"[backtrace] of 'nm ' in the bug report." JIM_NL); } #endif @@ -1717,6 +1705,7 @@ void Jim_FreeObj(Jim_Interp *interp, Jim_Obj *objPtr) Jim_Panic(interp,"!!!Object %p freed with bad refcount %d, type=%s", objPtr, objPtr->refCount, objPtr->typePtr ? objPtr->typePtr->name : ""); } + /* Free the internal representation */ Jim_FreeIntRep(interp, objPtr); /* Free the string representation */ @@ -2548,13 +2537,13 @@ int qsortCompareStringPointers(const void *a, const void *b) * * Note that this object uses shared strings for filenames, and the * pointer to the filename together with the line number is taken into - * the space for the "inline" internal represenation of the Jim_Object, + * the space for the "inline" internal representation of the Jim_Object, * so there is almost memory zero-overhead. * * Also the object will be converted to something else if the given * token it represents in the source file is not something to be * evaluated (not a script), and will be specialized in some other way, - * so the time overhead is alzo null. + * so the time overhead is also null. * ---------------------------------------------------------------------------*/ static void FreeSourceInternalRep(Jim_Interp *interp, Jim_Obj *objPtr); @@ -2694,7 +2683,7 @@ typedef struct ScriptToken { * and "subst" objects. In the second case, the cmdStruct related * fields are not used at all, but there is an additional field used * that is 'substFlags': this represents the flags used to turn - * the string into the intenral representation used to perform the + * the string into the internal representation used to perform the * substitution. If this flags are not what the application requires * the scriptObj is created again. For example the script: * @@ -2725,8 +2714,9 @@ void FreeScriptInternalRep(Jim_Interp *interp, Jim_Obj *objPtr) script->inUse--; if (script->inUse != 0) return; for (i = 0; i < script->len; i++) { - if (script->token[i].objPtr != NULL) + if (script->token[i].objPtr != NULL) { Jim_DecrRefCount(interp, script->token[i].objPtr); + } } Jim_Free(script->token); Jim_Free(script->cmdStruct); @@ -2777,14 +2767,14 @@ static void ScriptObjAddToken(Jim_Interp *interp, struct ScriptObj *script, Jim_Free(strtoken); return; } - /* Make space for a new istruction */ + /* Make space for a new instruction */ script->len++; script->token = Jim_Realloc(script->token, sizeof(ScriptToken)*script->len); /* Initialize the new token */ token = script->token+(script->len-1); token->type = type; - /* Every object is intially as a string, but the + /* Every object is initially a string, but the * internal type may be specialized during execution of the * script. */ token->objPtr = Jim_NewStringObjNoAlloc(interp, strtoken, len); @@ -2804,7 +2794,7 @@ static void ScriptObjAddInt(struct ScriptObj *script, int val) script->cmdStruct[script->csLen++] = val; } -/* Search a Jim_Obj contained in 'script' with the same stinrg repr. +/* Search a Jim_Obj contained in 'script' with the same string repr. * of objPtr. Search nested script objects recursively. */ static Jim_Obj *ScriptSearchLiteral(Jim_Interp *interp, ScriptObj *script, ScriptObj *scriptBarrier, Jim_Obj *objPtr) @@ -2827,13 +2817,18 @@ static Jim_Obj *ScriptSearchLiteral(Jim_Interp *interp, ScriptObj *script, script->token[i].objPtr->internalRep.ptr; /* Don't recursively enter the script we are trying * to make shared to avoid circular references. */ - if (subScript == scriptBarrier) continue; - if (subScript != script) { - foundObjPtr = - ScriptSearchLiteral(interp, subScript, - scriptBarrier, objPtr); - if (foundObjPtr != NULL) - return foundObjPtr; + if (subScript == scriptBarrier) { + continue; + } + if (subScript == script) { + continue; + } + + foundObjPtr = + ScriptSearchLiteral(interp, subScript, + scriptBarrier, objPtr); + if (foundObjPtr != NULL) { + return foundObjPtr; } } } @@ -2844,18 +2839,26 @@ static Jim_Obj *ScriptSearchLiteral(Jim_Interp *interp, ScriptObj *script, static void ScriptShareLiterals(Jim_Interp *interp, ScriptObj *script, ScriptObj *topLevelScript) { + /* XXX: This doesn't work work :-( */ +#if 0 int i, j; - return; /* Try to share with toplevel object. */ if (topLevelScript != NULL) { for (i = 0; i < script->len; i++) { Jim_Obj *foundObjPtr; char *str = script->token[i].objPtr->bytes; - if (script->token[i].objPtr->refCount != 1) continue; - if (script->token[i].objPtr->typePtr == &scriptObjType) continue; - if (strchr(str, ' ') || strchr(str, '\n')) continue; + if (script->token[i].objPtr->refCount != 1) { + continue; + } + if (script->token[i].objPtr->typePtr == &scriptObjType) { + continue; + } + if (strchr(str, ' ') || strchr(str, '\n')) { + continue; + } + foundObjPtr = ScriptSearchLiteral(interp, topLevelScript, script, /* barrier */ @@ -2868,12 +2871,17 @@ static void ScriptShareLiterals(Jim_Interp *interp, ScriptObj *script, } } } + /* Try to share locally */ for (i = 0; i < script->len; i++) { char *str = script->token[i].objPtr->bytes; - if (script->token[i].objPtr->refCount != 1) continue; - if (strchr(str, ' ') || strchr(str, '\n')) continue; + if (script->token[i].objPtr->refCount != 1) { + continue; + } + if (strchr(str, ' ') || strchr(str, '\n')) { + continue; + } for (j = 0; j < script->len; j++) { if (script->token[i].objPtr != script->token[j].objPtr && @@ -2888,6 +2896,7 @@ static void ScriptShareLiterals(Jim_Interp *interp, ScriptObj *script, } } } +#endif } /* This method takes the string representation of an object @@ -2989,6 +2998,7 @@ int SetScriptFromAny(Jim_Interp *interp, struct Jim_Obj *objPtr) tokens++; } } + /* Perform literal sharing, but only for objects that appear * to be scripts written as literals inside the source code, * and not computed at runtime. Literal sharing is a costly @@ -2998,13 +3008,12 @@ int SetScriptFromAny(Jim_Interp *interp, struct Jim_Obj *objPtr) if (propagateSourceInfo && interp->framePtr->procBodyObjPtr) { Jim_Obj *bodyObjPtr = interp->framePtr->procBodyObjPtr; if (bodyObjPtr->typePtr == &scriptObjType) { - ScriptObj *bodyScript = - bodyObjPtr->internalRep.ptr; - ScriptShareLiterals(interp, script, bodyScript); + ScriptShareLiterals(interp, script, bodyObjPtr->internalRep.ptr); } } else if (propagateSourceInfo) { ScriptShareLiterals(interp, script, NULL); } + /* Free the old internal rep and set the new one. */ Jim_FreeIntRep(interp, objPtr); Jim_SetIntRepPtr(objPtr, script); @@ -3353,7 +3362,7 @@ static int Jim_NameIsDictSugar(const char *str, int len) /* This method should be called only by the variable API. * It returns JIM_OK on success (variable already exists), - * JIM_ERR if it does not exists, JIM_DICT_GLUE if it's not + * JIM_ERR if it does not exists, JIM_DICT_SUGAR if it's not * a variable name, but syntax glue for [dict] i.e. the last * character is ')' */ int SetVariableFromAny(Jim_Interp *interp, struct Jim_Obj *objPtr) @@ -3361,10 +3370,11 @@ int SetVariableFromAny(Jim_Interp *interp, struct Jim_Obj *objPtr) Jim_HashEntry *he; const char *varName; int len; + Jim_CallFrame *framePtr = interp->framePtr; /* Check if the object is already an uptodate variable */ if (objPtr->typePtr == &variableObjType && - objPtr->internalRep.varValue.callFrameId == interp->framePtr->id) { + objPtr->internalRep.varValue.callFrameId == framePtr->id) { return JIM_OK; /* nothing to do */ } if (objPtr->typePtr == &dictSubstObjType) { @@ -3376,26 +3386,27 @@ int SetVariableFromAny(Jim_Interp *interp, struct Jim_Obj *objPtr) if (Jim_NameIsDictSugar(varName, len)) return JIM_DICT_SUGAR; if (varName[0] == ':' && varName[1] == ':') { - he = Jim_FindHashEntry(&interp->topFramePtr->vars, varName + 2); + framePtr = interp->topFramePtr; + he = Jim_FindHashEntry(&framePtr->vars, varName + 2); if (he == NULL) { return JIM_ERR; } } else { /* Lookup this name into the variables hash table */ - he = Jim_FindHashEntry(&interp->framePtr->vars, varName); + he = Jim_FindHashEntry(&framePtr->vars, varName); if (he == NULL) { /* Try with static vars. */ - if (interp->framePtr->staticVars == NULL) + if (framePtr->staticVars == NULL) return JIM_ERR; - if (!(he = Jim_FindHashEntry(interp->framePtr->staticVars, varName))) + if (!(he = Jim_FindHashEntry(framePtr->staticVars, varName))) return JIM_ERR; } } /* Free the old internal repr and set the new one. */ Jim_FreeIntRep(interp, objPtr); objPtr->typePtr = &variableObjType; - objPtr->internalRep.varValue.callFrameId = interp->framePtr->id; + objPtr->internalRep.varValue.callFrameId = framePtr->id; objPtr->internalRep.varValue.varPtr = (void*)he->val; return JIM_OK; } @@ -3418,6 +3429,8 @@ int Jim_SetVariable(Jim_Interp *interp, Jim_Obj *nameObjPtr, Jim_Obj *valObjPtr) int err; if ((err = SetVariableFromAny(interp, nameObjPtr)) != JIM_OK) { + Jim_CallFrame *framePtr = interp->framePtr; + /* Check for [dict] syntax sugar. */ if (err == JIM_DICT_SUGAR) return JimDictSugarSet(interp, nameObjPtr, valObjPtr); @@ -3431,16 +3444,16 @@ int Jim_SetVariable(Jim_Interp *interp, Jim_Obj *nameObjPtr, Jim_Obj *valObjPtr) /* Insert the new variable */ if (name[0] == ':' && name[1] == ':') { /* Into to the top evel frame */ - Jim_AddHashEntry(&interp->topFramePtr->vars, name + 2, var); + framePtr = interp->topFramePtr; + Jim_AddHashEntry(&framePtr->vars, name + 2, var); } else { - Jim_AddHashEntry(&interp->framePtr->vars, name, var); + Jim_AddHashEntry(&framePtr->vars, name, var); } /* Make the object int rep a variable */ Jim_FreeIntRep(interp, nameObjPtr); nameObjPtr->typePtr = &variableObjType; - nameObjPtr->internalRep.varValue.callFrameId = - interp->framePtr->id; + nameObjPtr->internalRep.varValue.callFrameId = framePtr->id; nameObjPtr->internalRep.varValue.varPtr = var; } else { var = nameObjPtr->internalRep.varValue.varPtr; @@ -3507,6 +3520,15 @@ int Jim_SetVariableLink(Jim_Interp *interp, Jim_Obj *nameObjPtr, const char *varName; int len; + varName = Jim_GetString(nameObjPtr, &len); + + if (Jim_FindHashEntry(&interp->framePtr->vars, varName)) { + Jim_SetResultString(interp, "", -1); + Jim_AppendStrings(interp, Jim_GetResult(interp), + "variable \"", varName, "\" already exists", NULL); + return JIM_ERR; + } + /* Check for cycles. */ if (interp->framePtr == targetCallFrame) { Jim_Obj *objPtr = targetNameObjPtr; @@ -3525,7 +3547,6 @@ int Jim_SetVariableLink(Jim_Interp *interp, Jim_Obj *nameObjPtr, objPtr = varPtr->objPtr; } } - varName = Jim_GetString(nameObjPtr, &len); if (Jim_NameIsDictSugar(varName, len)) { Jim_SetResultString(interp, "Dict key syntax invalid as link source", -1); @@ -3659,17 +3680,21 @@ int Jim_UnsetVariable(Jim_Interp *interp, Jim_Obj *nameObjPtr, int flags) } return retval; } else { + Jim_CallFrame *framePtr = interp->framePtr; + name = Jim_GetString(nameObjPtr, NULL); if (name[0] == ':' && name[1] == ':') { - if (Jim_DeleteHashEntry(&interp->topFramePtr->vars, name + 2) != JIM_OK) { + framePtr = interp->topFramePtr; + if (Jim_DeleteHashEntry(&framePtr->vars, name + 2) != JIM_OK) { return JIM_ERR; } } - else if (Jim_DeleteHashEntry(&interp->framePtr->vars, name) != JIM_OK) { + else if (Jim_DeleteHashEntry(&framePtr->vars, name) != JIM_OK) { return JIM_ERR; } /* Change the callframe id, invalidating var lookup caching */ - JimChangeCallFrameId(interp, interp->framePtr); + JimChangeCallFrameId(interp, framePtr); + return JIM_OK; } } @@ -4013,9 +4038,7 @@ void UpdateStringOfReference(struct Jim_Obj *objPtr) * i.e. inside the range [_a-zA-Z0-9] */ static int isrefchar(int c) { - if (c == '_' || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || - (c >= '0' && c <= '9')) return 1; - return 0; + return (c == '_' || isalnum(c)); } int SetReferenceFromAny(Jim_Interp *interp, Jim_Obj *objPtr) @@ -4223,7 +4246,7 @@ int Jim_Collect(Jim_Interp *interp) if (len-(p-str) < JIM_REFERENCE_SPACE) break; if (p[41] != '>' || p[19] != '>' || p[20] != '.') break; for (i = 21; i <= 40; i++) - if (!isdigit((int)p[i])) + if (!isdigit(p[i])) break; /* Get the ID */ memcpy(buf, p+21, 20); @@ -4417,11 +4440,11 @@ void Jim_FreeInterp(Jim_Interp *i) printf("Objects still in the free list:" JIM_NL); while(objPtr) { const char *type = objPtr->typePtr ? - objPtr->typePtr->name : ""; - printf("%p \"%-10s\": '%.20s' (refCount: %d)" JIM_NL, - objPtr, type, + objPtr->typePtr->name : "string"; + printf("%p (%d) %-10s: '%.20s'" JIM_NL, + objPtr, objPtr->refCount, type, objPtr->bytes ? objPtr->bytes - : "(null)", objPtr->refCount); + : "(null)"); if (objPtr->typePtr == &sourceObjType) { printf( "FILE %s LINE %d" JIM_NL, objPtr->internalRep.sourceValue.fileName, @@ -6318,7 +6341,7 @@ int JimParseExpression(struct JimParserCtx *pc) break; case '-': if ((pc->tt == JIM_TT_NONE || pc->tt == JIM_TT_EXPR_OPERATOR) && - isdigit((int)*(pc->p+1))) + isdigit(*(pc->p+1))) return JimParseExprNumber(pc); else return JimParseExprOperator(pc); @@ -6355,8 +6378,8 @@ int JimParseExprNumber(struct JimParserCtx *pc) if (*pc->p == '-') { pc->p++; pc->len--; } - while ( isdigit((int)*pc->p) - || (allowhex && isxdigit((int)*pc->p) ) + while ( isdigit(*pc->p) + || (allowhex && isxdigit(*pc->p) ) || (allowdot && *pc->p == '.') || (pc->p-pc->tstart == 1 && *pc->tstart == '0' && (*pc->p == 'x' || *pc->p == 'X')) @@ -6598,7 +6621,7 @@ static void ExprShareLiterals(Jim_Interp *interp, ExprByteCode *expr, * a &L b &R * * "|L" checks if 'a' is true: - * 1) if it is true pushes 1 and skips istructions to reach + * 1) if it is true pushes 1 and skips instructions to reach * the opcode just after |R. * 2) if it is false does nothing. * "|R" checks if 'b' is true: @@ -6606,7 +6629,7 @@ static void ExprShareLiterals(Jim_Interp *interp, ExprByteCode *expr, * * "&L" checks if 'a' is true: * 1) if it is true does nothing. - * 2) If it is false pushes 0 and skips istructions to reach + * 2) If it is false pushes 0 and skips instructions to reach * the opcode just after &R * "&R" checks if 'a' is true: * if it is true pushes 1, otherwise pushes 0. @@ -6900,7 +6923,7 @@ int Jim_EvalExpression(Jim_Interp *interp, Jim_Obj *exprObjPtr, else stack = staticStack; - /* Execute every istruction */ + /* Execute every instruction */ for (i = 0; i < expr->len; i++) { Jim_Obj *A, *B, *C, *objPtr; jim_wide wA, wB, wC; @@ -7623,7 +7646,7 @@ JimScanAString(Jim_Interp *interp, const char *sdescr, const char *str) } /* And after all the mess above, the real work begin ... */ while (str && *str) { - if (!sdescr && isspace((int)*str)) + if (!sdescr && isspace(*str)) break; /* EOS via WS if unspecified */ if (JimTestBit(charset, *str)) *buffer++ = *str++; else break; /* EOS via mismatch if specified scanning */ @@ -7656,8 +7679,8 @@ static int ScanOneEntry(Jim_Interp *interp, const char *str, long pos, * the string-to-be-parsed accordingly */ for (i=0; str[pos] && descr->prefix[i]; ++i) { /* If prefix require, skip WS */ - if (isspace((int)descr->prefix[i])) - while (str[pos] && isspace((int)str[pos])) ++pos; + if (isspace(descr->prefix[i])) + while (str[pos] && isspace(str[pos])) ++pos; else if (descr->prefix[i] != str[pos]) break; /* Prefix do not match here, leave the loop */ else @@ -7670,7 +7693,7 @@ static int ScanOneEntry(Jim_Interp *interp, const char *str, long pos, } /* For all but following conversion, skip leading WS */ if (descr->type != 'c' && descr->type != '[' && descr->type != 'n') - while (isspace((int)str[pos])) ++pos; + while (isspace(str[pos])) ++pos; /* Determine how much skipped/scanned so far */ scanned = pos - anchor; if (descr->type == 'n') { @@ -7776,10 +7799,9 @@ Jim_Obj *Jim_ScanString(Jim_Interp *interp, Jim_Obj *strObjPtr, Jim_Obj *emptyStr = 0; ScanFmtStringObj *fmtObj; - /* If format specification is not an object, convert it! */ + /* This should never happen. The format object should already be of the correct type */ if (fmtObjPtr->typePtr != &scanFmtStringObjType) { Jim_Panic(interp, "Jim_ScanString() for non-scan format"); - /*SetScanFmtFromAny(interp, fmtObjPtr);*/ } fmtObj = (ScanFmtStringObj*)fmtObjPtr->internalRep.ptr; /* Check if format specification was valid */ @@ -8178,6 +8200,7 @@ int Jim_EvalObj(Jim_Interp *interp, Jim_Obj *scriptObjPtr) Jim_IncrRefCount(scriptObjPtr); /* Make sure it's shared. */ script = Jim_GetScript(interp, scriptObjPtr); + /* Now we have to make sure the internal repr will not be * freed on shimmering. * @@ -8270,8 +8293,8 @@ int Jim_EvalObj(Jim_Interp *interp, Jim_Obj *scriptObjPtr) Jim_IncrRefCount(argv[j]); i += 2; } else { - /* For interpolation we call an helper - * function doing the work for us. */ + /* For interpolation we call a helper + * function to do the work for us. */ if ((retcode = Jim_InterpolateTokens(interp, token+i, tokens, &tmpObjPtr)) != JIM_OK) { @@ -9383,6 +9406,7 @@ noopt: &boolean)) != JIM_OK) return retval; if (!boolean) break; + if ((retval = Jim_EvalObj(interp, argv[2])) != JIM_OK) { switch(retval) { case JIM_BREAK: @@ -10523,6 +10547,7 @@ static int Jim_ProcCoreCommand(Jim_Interp *interp, int argc, { int argListLen; int arityMin, arityMax; + int i; if (argc != 4 && argc != 5) { Jim_WrongNumArgs(interp, 1, argv, "name arglist ?statics? body"); @@ -10555,6 +10580,24 @@ static int Jim_ProcCoreCommand(Jim_Interp *interp, int argc, } arityMin--; } + for (i = 0; i < argListLen; i++) { + int len; + Jim_ListIndex(interp, argv[2], i, &argPtr, JIM_NONE); + Jim_GetString(argPtr, &len); + Jim_ListLength(interp, argPtr, &len); + if (len == 0) { + Jim_SetResultString(interp, "", 0); + Jim_AppendStrings(interp, Jim_GetResult(interp), + "procedure \"", Jim_GetString(argv[1], NULL), "\" has argument with no name", NULL); + return JIM_ERR; + } + if (len > 2) { + Jim_SetResultString(interp, "", 0); + Jim_AppendStrings(interp, Jim_GetResult(interp), + "too many fields in argument specifier \"", Jim_GetString(argPtr, NULL), "\"", NULL); + return JIM_ERR; + } + } } if (argc == 4) { return Jim_CreateProcedure(interp, Jim_GetString(argv[1], NULL), diff --git a/tcltests/test_clientserver.tcl b/tcltests/test_clientserver.tcl index c1e555e..c4d025a 100644 --- a/tcltests/test_clientserver.tcl +++ b/tcltests/test_clientserver.tcl @@ -20,7 +20,7 @@ if {[os.fork] == 0} { sleep .1 - set f [aio.socket stream localhost:9876] + set f [socket stream localhost:9876] set done 0 @@ -65,7 +65,7 @@ verbose "parent: opening socket" set done 0 # This will be our server -set f [aio.socket stream.server 0.0.0.0:9876] +set f [socket stream.server 0.0.0.0:9876] proc server_onread {f} { verbose "parent: onread (server) got connection on $f" diff --git a/tcltests/test_eventloop.tcl b/tcltests/test_eventloop.tcl index f32a708..13e4ab2 100644 --- a/tcltests/test_eventloop.tcl +++ b/tcltests/test_eventloop.tcl @@ -2,7 +2,7 @@ if {[info commands vwait] eq ""} { return "noimpl" } -set f [aio.socket stream localhost:80] +set f [socket stream localhost:80] set count 0 set done 0 diff --git a/test.tcl b/test.tcl index dc0d5da..62d2d9f 100644 --- a/test.tcl +++ b/test.tcl @@ -3616,9 +3616,11 @@ test regexp-1.5 {basic regexp operation} { regexp {^([^ ]*)[ ]*([^ ]*)} "" a } {1} -test regexp-1.6 {basic regexp operation} { - list [catch {regexp {} abc} msg] $msg -} {0 1} +# This null case doesn't work with some regex libraries +# No great loss +#test regexp-1.6 {basic regexp operation} { +# list [catch {regexp {} abc} msg] $msg +#} {0 1} test regexp-2.1 {getting substrings back from regexp} { set foo {} diff --git a/tests/concat.test b/tests/concat.test new file mode 100644 index 0000000..333b634 --- /dev/null +++ b/tests/concat.test @@ -0,0 +1,32 @@ +source testing.tcl + +test concat-1.1 {simple concatenation} { + concat a b c d e f g +} {a b c d e f g} +test concat-1.2 {merging lists together} { + concat a {b c d} {e f g h} +} {a b c d e f g h} +test concat-1.3 {merge lists, retain sub-lists} { + concat a {b {c d}} {{e f}} g h +} {a b {c d} {e f} g h} +test concat-1.4 {special characters} { + concat a\{ {b \{c d} \{d +} "a{ b \\{c d {d" + +test concat-2.1 {error: one empty argument} { + concat {} +} {} + +test concat-3.1 {error: no arguments} { + list [catch concat msg] $msg +} {0 {}} + +test concat-4.1 {pruning off extra white space} { + concat {} {a b c} +} {a b c} +test concat-4.2 {pruning off extra white space} { + concat x y " a b c \n\t " " " " def " +} {x y a b c def} +test concat-4.3 {pruning off extra white space sets length correctly} { + llength [concat { {{a}} }] +} 1 diff --git a/tests/misc.test b/tests/misc.test index fec7feb..53dce1c 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -9,6 +9,16 @@ test regr-1.1 "Double dereference arrays" { set b($a($chan)) } {2} +# Will assert on exit if the bug exists +test regr-1.2 "Reference count shared literals" { + proc a {} { + while {1} {break} + } + a + rename a "" + return 1 +} {1} + section "I/O Testing" test io-1.1 "Read last line with no newline" { diff --git a/tests/perf.test b/tests/perf.test index 8535dd2..1cd231c 100644 --- a/tests/perf.test +++ b/tests/perf.test @@ -11,7 +11,7 @@ proc bench {name cmd} { } proc set_dict_sugar {} { - for {set i 0} {$i < 100000} {incr i} { + for {set i 0} {$i < 20000} {incr i} { set a(b) $i } } @@ -20,7 +20,7 @@ proc set_dict_sugar {} { # speedup since a($b) needs to be interpolated and reparsed every time proc set_var_dict_sugar {} { set b b - for {set i 0} {$i < 100000} {incr i} { + for {set i 0} {$i < 20000} {incr i} { set a($b) $i } } diff --git a/tests/proc.test b/tests/proc.test new file mode 100644 index 0000000..2e65c35 --- /dev/null +++ b/tests/proc.test @@ -0,0 +1,379 @@ +# Commands covered: proc, return, global +# +# This file, proc-old.test, includes the original set of tests for Tcl's +# proc, return, and global commands. There is now a new file proc.test +# that contains tests for the tclProc.c source file. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: proc-old.test,v 1.6 2000/04/10 17:19:03 ericm Exp $ + +source testing.tcl + +catch {rename t1 ""} +catch {rename foo ""} + +proc tproc {} {return a; return b} +test proc-old-1.1 {simple procedure call and return} {tproc} a +proc tproc x { + set x [expr $x+1] + return $x +} +test proc-old-1.2 {simple procedure call and return} {tproc 2} 3 +test proc-old-1.3 {simple procedure call and return} { + proc tproc {} {return foo} +} {} +test proc-old-1.4 {simple procedure call and return} { + proc tproc {} {return} + tproc +} {} +proc tproc1 {a} {incr a; return $a} +proc tproc2 {a b} {incr a; return $a} +test proc-old-1.5 {simple procedure call and return (2 procs with same body but different parameters)} { + list [tproc1 123] [tproc2 456 789] +} {124 457} +test proc-old-1.6 {simple procedure call and return (shared proc body string)} { + set x {} + proc tproc {} {} ;# body is shared with x + list [tproc] [append x foo] +} {{} foo} + +test proc-old-2.1 {local and global variables} { + proc tproc x { + set x [expr $x+1] + return $x + } + set x 42 + list [tproc 6] $x +} {7 42} +test proc-old-2.2 {local and global variables} { + proc tproc x { + set y [expr $x+1] + return $y + } + set y 18 + list [tproc 6] $y +} {7 18} +test proc-old-2.3 {local and global variables} { + proc tproc x { + global y + set y [expr $x+1] + return $y + } + set y 189 + list [tproc 6] $y +} {7 7} +test proc-old-2.4 {local and global variables} { + proc tproc x { + global y + return [expr $x+$y] + } + set y 189 + list [tproc 6] $y +} {195 189} +catch {unset _undefined_} +test proc-old-2.5 {local and global variables} { + proc tproc x { + global _undefined_ + return $_undefined_ + } + list [catch {tproc xxx} msg] $msg +} {1 {can't read "_undefined_": no such variable}} +test proc-old-2.6 {local and global variables} { + set a 114 + set b 115 + global a b + list $a $b +} {114 115} + +proc do {cmd} {eval $cmd} +test proc-old-3.1 {local and global arrays} { + catch {unset a} + set a(0) 22 + list [catch {do {global a; set a(0)}} msg] $msg +} {0 22} +test proc-old-3.2 {local and global arrays} { + catch {unset a} + set a(x) 22 + list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x) +} {0 newValue newValue} +test proc-old-3.3 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + list [catch {do {global a; unset a(y)}; array names a} msg] $msg +} {0 x} +test proc-old-3.4 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + list [catch {do {global a; unset a; info exists a}} msg] $msg \ + [info exists a] +} {0 0 0} +test proc-old-3.5 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + list [catch {do {global a; unset a(y); array names a}} msg] $msg +} {0 x} +catch {unset a} +test proc-old-3.6 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + do {global a; do {global a; unset a}; set a(z) 22} + list [catch {array names a} msg] $msg +} {0 z} +test proc-old-3.1 {arguments and defaults} { + proc tproc {x y z} { + return [list $x $y $z] + } + tproc 11 12 13 +} {11 12 13} +test proc-old-3.2 {arguments and defaults} { + proc tproc {x y z} { + return [list $x $y $z] + } + list [catch {tproc 11 12} msg] +} {1} +test proc-old-3.3 {arguments and defaults} { + proc tproc {x y z} { + return [list $x $y $z] + } + list [catch {tproc 11 12 13 14} msg] +} {1} +test proc-old-3.4 {arguments and defaults} { + proc tproc {x {y y-default} {z z-default}} { + return [list $x $y $z] + } + tproc 11 12 13 +} {11 12 13} +test proc-old-3.5 {arguments and defaults} { + proc tproc {x {y y-default} {z z-default}} { + return [list $x $y $z] + } + tproc 11 12 +} {11 12 z-default} +test proc-old-3.6 {arguments and defaults} { + proc tproc {x {y y-default} {z z-default}} { + return [list $x $y $z] + } + tproc 11 +} {11 y-default z-default} +test proc-old-3.7 {arguments and defaults} { + proc tproc {x {y y-default} {z z-default}} { + return [list $x $y $z] + } + list [catch {tproc} msg] +} {1} +test proc-old-3.8 {arguments and defaults} { + list [catch { + proc tproc {x {y y-default} z} { + return [list $x $y $z] + } + tproc 2 3 + } msg] +} {1} +test proc-old-3.9 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + tproc 2 3 4 5 +} {2 3 {4 5}} +test proc-old-3.10 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + tproc 2 3 +} {2 3 {}} +test proc-old-3.11 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + tproc 2 +} {2 y-default {}} +test proc-old-3.12 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + list [catch {tproc} msg] +} {1} + +test proc-old-4.1 {variable numbers of arguments} { + proc tproc args {return $args} + tproc +} {} +test proc-old-4.2 {variable numbers of arguments} { + proc tproc args {return $args} + tproc 1 2 3 4 5 6 7 8 +} {1 2 3 4 5 6 7 8} +test proc-old-4.3 {variable numbers of arguments} { + proc tproc args {return $args} + tproc 1 {2 3} {4 {5 6} {{{7}}}} 8 +} {1 {2 3} {4 {5 6} {{{7}}}} 8} +test proc-old-4.4 {variable numbers of arguments} { + proc tproc {x y args} {return $args} + tproc 1 2 3 4 5 6 7 +} {3 4 5 6 7} +test proc-old-4.5 {variable numbers of arguments} { + proc tproc {x y args} {return $args} + tproc 1 2 +} {} +test proc-old-4.6 {variable numbers of arguments} { + proc tproc {x missing args} {return $args} + list [catch {tproc 1} msg] +} {1} + +test proc-old-5.1 {error conditions} { + list [catch {proc} msg] +} {1} +test proc-old-5.2 {error conditions} { + list [catch {proc tproc b} msg] +} {1} +test proc-old-5.3 {error conditions} { + list [catch {proc tproc b c d e} msg] +} {1} + + + +test proc-old-5.5 {error conditions} { + list [catch {proc tproc {{} y} {return foo}} msg] $msg +} {1 {procedure "tproc" has argument with no name}} +test proc-old-5.6 {error conditions} { + list [catch {proc tproc {{} y} {return foo}} msg] $msg +} {1 {procedure "tproc" has argument with no name}} +test proc-old-5.7 {error conditions} { + list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg +} {1 {too many fields in argument specifier "x 1 2"}} +test proc-old-5.8 {error conditions} { + catch {return} +} 2 +test proc-old-5.9 {error conditions} { + list [catch {global} msg] $msg +} {1 {wrong # args: should be "global varName ?varName ...?"}} +proc tproc {} { + set a 22 + global a +} +test proc-old-5.10 {error conditions} { + list [catch {tproc} msg] $msg +} {1 {variable "a" already exists}} +test proc-old-5.11 {error conditions} { + catch {rename tproc {}} + catch { + proc tproc {x {} z} {return foo} + } + list [catch {tproc 1} msg] $msg +} {1 {invalid command name "tproc"}} +test proc-old-5.12 {error conditions} { + proc tproc {} { + set a 22 + error "error in procedure" + return + } + list [catch tproc msg] $msg +} {1 {error in procedure}} + +# The tests below will really only be useful when run under Purify or +# some other system that can detect accesses to freed memory... + +test proc-old-6.1 {procedure that redefines itself} { + proc tproc {} { + proc tproc {} { + return 44 + } + return 45 + } + tproc +} 45 +test proc-old-6.2 {procedure that deletes itself} { + proc tproc {} { + rename tproc {} + return 45 + } + tproc +} 45 + +proc tproc code { + return -code $code abc +} +test proc-old-7.1 {return with special completion code} { + list [catch {tproc ok} msg] $msg +} {0 abc} +test proc-old-7.2 {return with special completion code} { + list [catch {tproc error} msg] $msg +} {1 abc} +test proc-old-7.3 {return with special completion code} { + list [catch {tproc return} msg] $msg +} {2 abc} +test proc-old-7.4 {return with special completion code} { + list [catch {tproc break} msg] $msg +} {3 abc} +test proc-old-7.5 {return with special completion code} { + list [catch {tproc continue} msg] $msg +} {4 abc} +test proc-old-7.6 {return with special completion code} { + list [catch {tproc -14} msg] $msg +} {-14 abc} +test proc-old-7.7 {return with special completion code} { + list [catch {tproc gorp} msg] +} {1} +test proc-old-7.8 {return with special completion code} { + list [catch {tproc 10b} msg] +} {1} +test proc-old-7.9 {return with special completion code} { + proc tproc2 {} { + tproc return + } + list [catch tproc2 msg] $msg +} {0 abc} +test proc-old-7.10 {return with special completion code} { + proc tproc2 {} { + return -code error + } + list [catch tproc2 msg] $msg +} {1 {}} + +test proc-old-8.1 {unset and undefined local arrays} { + proc t1 {} { + foreach v {xxx, yyy} { + catch {unset $v} + } + set yyy(foo) bar + } + t1 +} bar + +test proc-old-9.1 {empty command name} { + catch {rename {} ""} + proc t1 {args} { + return + } + set v [t1] + catch {$v} +} 1 + +test proc-old-10.1 {ByteCode epoch change during recursive proc execution} { + proc t1 x { + set y 20 + rename expr expr.old + rename expr.old expr + if $x then {t1 0} ;# recursive call after foo's code is invalidated + return 20 + } + t1 1 +} 20 + +# cleanup +catch {rename t1 ""} +catch {rename foo ""} + +testreport -- cgit v1.1