diff options
| -rw-r--r-- | doc/jim_tcl.txt | 2 | ||||
| -rw-r--r-- | jim.c | 91 | ||||
| -rw-r--r-- | jim.h.in | 2 | ||||
| -rw-r--r-- | stdlib.tcl | 41 | ||||
| -rw-r--r-- | tclcompat.tcl | 21 |
5 files changed, 107 insertions, 50 deletions
diff --git a/doc/jim_tcl.txt b/doc/jim_tcl.txt index c826221..c7adfc2 100644 --- a/doc/jim_tcl.txt +++ b/doc/jim_tcl.txt @@ -3902,7 +3902,7 @@ the EVENTLOOP API. The special type 'pipe' isn't really a socket. - foreach {r w} [socket pipe] break + lassign [socket pipe] r w # Must close $w after exec exec ps >@$w & @@ -116,6 +116,8 @@ static Jim_Obj *Jim_ExpandDictSugar(Jim_Interp *interp, Jim_Obj *objPtr); static void SetDictSubstFromAny(Jim_Interp *interp, Jim_Obj *objPtr); static void JimSetFailedEnumResult(Jim_Interp *interp, const char *arg, const char *badtype, const char *prefix, const char * const *tablePtr, const char *name); static void JimDeleteLocalProcs(Jim_Interp *interp); +static int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, const char *filename, int linenr, int argc, Jim_Obj *const *argv); +static int JimEvalObjVector(Jim_Interp *interp, int objc, Jim_Obj *const *objv, const char *filename, int linenr); static const Jim_HashTableType JimVariablesHashTableType; @@ -8620,11 +8622,8 @@ static void JimPrngSeed(Jim_Interp *interp, const unsigned char *seed, #define JIM_EVAL_SARGV_LEN 8 /* static arguments vector length */ #define JIM_EVAL_SINTV_LEN 8 /* static interpolation vector length */ -static int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc, - Jim_Obj *const *argv); - /* Handle calls to the [unknown] command */ -static int JimUnknown(Jim_Interp *interp, int argc, Jim_Obj *const *argv) +static int JimUnknown(Jim_Interp *interp, int argc, Jim_Obj *const *argv, const char *filename, int linenr) { Jim_Obj **v, *sv[JIM_EVAL_SARGV_LEN]; int retCode; @@ -8652,12 +8651,12 @@ static int JimUnknown(Jim_Interp *interp, int argc, Jim_Obj *const *argv) /* Make a copy of the arguments vector, but shifted on * the right of one position. The command name of the * command will be instead the first argument of the - * [unknonw] call. */ + * [unknown] call. */ memcpy(v+1, argv, sizeof(Jim_Obj*)*argc); v[0] = interp->unknown; /* Call it */ interp->unknown_called++; - retCode = Jim_EvalObjVector(interp, argc+1, v); + retCode = JimEvalObjVector(interp, argc+1, v, filename, linenr); interp->unknown_called--; /* Clean up */ @@ -8675,7 +8674,7 @@ static int JimUnknown(Jim_Interp *interp, int argc, Jim_Obj *const *argv) * list object generated by the UpdateStringOfList is made * in a way that ensures that every list element is a different * command argument. */ -int Jim_EvalObjVector(Jim_Interp *interp, int objc, Jim_Obj *const *objv) +static int JimEvalObjVector(Jim_Interp *interp, int objc, Jim_Obj *const *objv, const char *filename, int linenr) { int i, retcode; Jim_Cmd *cmdPtr; @@ -8686,7 +8685,7 @@ int Jim_EvalObjVector(Jim_Interp *interp, int objc, Jim_Obj *const *objv) /* Command lookup */ cmdPtr = Jim_GetCommand(interp, objv[0], JIM_ERRMSG); if (cmdPtr == NULL) { - retcode = JimUnknown(interp, objc, objv); + retcode = JimUnknown(interp, objc, objv, filename, linenr); } else { /* Call it -- Make sure result is an empty object. */ JimIncrCmdRefCount(cmdPtr); @@ -8695,7 +8694,7 @@ int Jim_EvalObjVector(Jim_Interp *interp, int objc, Jim_Obj *const *objv) interp->cmdPrivData = cmdPtr->privData; retcode = cmdPtr->cmdProc(interp, objc, objv); } else { - retcode = JimCallProcedure(interp, cmdPtr, objc, objv); + retcode = JimCallProcedure(interp, cmdPtr, filename, linenr, objc, objv); } JimDecrCmdRefCount(interp, cmdPtr); } @@ -8706,6 +8705,11 @@ int Jim_EvalObjVector(Jim_Interp *interp, int objc, Jim_Obj *const *objv) return retcode; } +int Jim_EvalObjVector(Jim_Interp *interp, int objc, Jim_Obj *const *objv) +{ + return JimEvalObjVector(interp, objc, objv, NULL, 0); +} + /* Interpolate the given tokens into a unique Jim_Obj returned by reference * via *objPtrPtr. This function is only called by Jim_EvalObj(). * The returned object has refcount = 0. */ @@ -8903,6 +8907,28 @@ static void JimDeleteLocalProcs(Jim_Interp *interp) } } +/* If listPtr is a list, call JimEvalObjVector() with the given source info. + * Otherwise eval with Jim_EvalObj() + */ +int Jim_EvalObjList(Jim_Interp *interp, Jim_Obj *listPtr, const char *filename, int linenr) +{ + if (!Jim_IsList(listPtr)) { + return Jim_EvalObj(interp, listPtr); + } + else { + int retcode = JIM_OK; + + if (listPtr->internalRep.listValue.len) { + Jim_IncrRefCount(listPtr); + retcode = JimEvalObjVector(interp, + listPtr->internalRep.listValue.len, + listPtr->internalRep.listValue.ele, filename, linenr); + Jim_DecrRefCount(interp, listPtr); + } + return retcode; + } +} + int Jim_EvalObj(Jim_Interp *interp, Jim_Obj *scriptObjPtr) { int i, j = 0, len; @@ -8915,16 +8941,10 @@ int Jim_EvalObj(Jim_Interp *interp, Jim_Obj *scriptObjPtr) interp->errorFlag = 0; - /* If the object is of type "list" and there is no - * string representation for this object, we can call + /* If the object is of type "list", we can call * a specialized version of Jim_EvalObj() */ - if (Jim_IsList(scriptObjPtr) && scriptObjPtr->internalRep.listValue.len) { - Jim_IncrRefCount(scriptObjPtr); - retcode = Jim_EvalObjVector(interp, - scriptObjPtr->internalRep.listValue.len, - scriptObjPtr->internalRep.listValue.ele); - Jim_DecrRefCount(interp, scriptObjPtr); - return retcode; + if (Jim_IsList(scriptObjPtr)) { + return Jim_EvalObjList(interp, scriptObjPtr, NULL, 0); } Jim_IncrRefCount(scriptObjPtr); /* Make sure it's shared. */ @@ -9089,12 +9109,12 @@ int Jim_EvalObj(Jim_Interp *interp, Jim_Obj *scriptObjPtr) interp->cmdPrivData = cmd->privData; retcode = cmd->cmdProc(interp, argc, argv); } else { - retcode = JimCallProcedure(interp, cmd, argc, argv); + retcode = JimCallProcedure(interp, cmd, script->fileName, cmdtoken->linenr, argc, argv); } JimDecrCmdRefCount(interp, cmd); } else { /* Call [unknown] */ - retcode = JimUnknown(interp, argc, argv); + retcode = JimUnknown(interp, argc, argv, script->fileName, cmdtoken->linenr); } if (interp->signal_level && interp->sigmask) { /* Check for a signal after each command */ @@ -9141,7 +9161,7 @@ err: * * This can be fixed just implementing callframes caching * in JimCreateCallFrame() and JimFreeCallFrame(). */ -int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc, +int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, const char *filename, int linenr, int argc, Jim_Obj *const *argv) { int i, d, retcode; @@ -9196,6 +9216,8 @@ int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc, callFramePtr->procArgsObjPtr = cmd->argListObjPtr; callFramePtr->procBodyObjPtr = cmd->bodyObjPtr; callFramePtr->staticVars = cmd->staticVars; + callFramePtr->filename = filename; + callFramePtr->line = linenr; Jim_IncrRefCount(cmd->argListObjPtr); Jim_IncrRefCount(cmd->bodyObjPtr); interp->framePtr = callFramePtr; @@ -9286,7 +9308,8 @@ int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc, while (retcode == JIM_EVAL) { Jim_Obj *resultScriptObjPtr = Jim_GetResult(interp); Jim_IncrRefCount(resultScriptObjPtr); - retcode = Jim_EvalObj(interp, resultScriptObjPtr); + /* Should be a list! */ + retcode = Jim_EvalObjList(interp, resultScriptObjPtr, filename, linenr); Jim_DecrRefCount(interp, resultScriptObjPtr); } /* Handle the JIM_RETURN return code */ @@ -9792,7 +9815,7 @@ static Jim_Obj *JimVariablesList(Jim_Interp *interp, Jim_Obj *patternObjPtr, } static int JimInfoLevel(Jim_Interp *interp, Jim_Obj *levelObjPtr, - Jim_Obj **objPtrPtr) + Jim_Obj **objPtrPtr, int info_level_cmd) { Jim_CallFrame *targetCallFrame; @@ -9804,9 +9827,18 @@ static int JimInfoLevel(Jim_Interp *interp, Jim_Obj *levelObjPtr, Jim_SetResultFormatted(interp, "bad level \"%#s\"", levelObjPtr); return JIM_ERR; } - *objPtrPtr = Jim_NewListObj(interp, - targetCallFrame->argv, - targetCallFrame->argc); + if (info_level_cmd) { + *objPtrPtr = Jim_NewListObj(interp, + targetCallFrame->argv, + targetCallFrame->argc); + } + else { + Jim_Obj *listObj = Jim_NewListObj(interp, NULL, 0); + Jim_ListAppendElement(interp, listObj, targetCallFrame->argv[0]); + Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, targetCallFrame->filename ?: "", -1)); + Jim_ListAppendElement(interp, listObj, Jim_NewIntObj(interp, targetCallFrame->line)); + *objPtrPtr = listObj; + } return JIM_OK; } @@ -12221,11 +12253,11 @@ static int Jim_InfoCoreCommand(Jim_Interp *interp, int argc, int mode = 0; static const char *commands[] = { - "body", "commands", "procs", "exists", "globals", "level", "locals", + "body", "commands", "procs", "exists", "globals", "level", "frame", "locals", "vars", "version", "patchlevel", "complete", "args", "hostname", "script", "source", "stacktrace", "nameofexecutable", "returncodes", NULL }; - enum {INFO_BODY, INFO_COMMANDS, INFO_PROCS, INFO_EXISTS, INFO_GLOBALS, INFO_LEVEL, + enum {INFO_BODY, INFO_COMMANDS, INFO_PROCS, INFO_EXISTS, INFO_GLOBALS, INFO_LEVEL, INFO_FRAME, INFO_LOCALS, INFO_VARS, INFO_VERSION, INFO_PATCHLEVEL, INFO_COMPLETE, INFO_ARGS, INFO_HOSTNAME, INFO_SCRIPT, INFO_SOURCE, INFO_STACKTRACE, INFO_NAMEOFEXECUTABLE, INFO_RETURNCODES }; @@ -12312,13 +12344,14 @@ static int Jim_InfoCoreCommand(Jim_Interp *interp, int argc, break; case INFO_LEVEL: + case INFO_FRAME: switch (argc) { case 2: Jim_SetResultInt(interp, interp->numLevels); break; case 3: - if (JimInfoLevel(interp, argv[2], &objPtr) != JIM_OK) { + if (JimInfoLevel(interp, argv[2], &objPtr, cmd == INFO_LEVEL) != JIM_OK) { return JIM_ERR; } Jim_SetResult(interp, objPtr); @@ -441,6 +441,8 @@ typedef struct Jim_CallFrame { Jim_Obj *procArgsObjPtr; /* arglist object of the running procedure */ Jim_Obj *procBodyObjPtr; /* body object of the running procedure */ struct Jim_CallFrame *nextFramePtr; + const char *filename; /* file and line of caller of this proc (if available) */ + int line; } Jim_CallFrame; /* The var structure. It just holds the pointer of the referenced @@ -4,15 +4,14 @@ proc alias {name args} { set prefix $args proc $name args prefix { - uplevel 1 $prefix $args + tailcall {*}$prefix {*}$args } } # Creates an anonymous procedure proc lambda {arglist args} { set name [ref {} function lambda.finalizer] - uplevel 1 [list proc $name $arglist {*}$args] - return $name + tailcall proc $name $arglist {*}$args } proc lambda.finalizer {name val} { @@ -23,7 +22,7 @@ proc lambda.finalizer {name val} { proc curry {args} { set prefix $args lambda args prefix { - uplevel 1 $prefix $args + tailcall {*}$prefix {*}$args } } @@ -38,3 +37,37 @@ proc curry {args} { proc function {value} { return $value } + +# Returns a list of proc filename line ... +# with 3 entries for each stack frame (proc), +# (deepest level first) +proc stacktrace {} { + set trace {} + foreach level [range 1 [info level]] { + lassign [info frame -$level] p f l + lappend trace $p $f $l + } + return $trace +} + +# Returns a human-readable version of a stack trace +proc stackdump {stacktrace} { + set result {} + set count 0 + foreach {l f p} [lreverse $stacktrace] { + if {$count} { + append result \n + } + incr count + if {$p ne ""} { + append result "in procedure '$p' " + if {$f ne ""} { + append result "called " + } + } + if {$f ne ""} { + append result "at file \"$f\", line $l" + } + } + return $result +} diff --git a/tclcompat.tcl b/tclcompat.tcl index 0c6c550..4a0929b 100644 --- a/tclcompat.tcl +++ b/tclcompat.tcl @@ -80,23 +80,12 @@ proc errorInfo {error {stacktrace ""}} { if {$stacktrace eq ""} { set stacktrace [info stacktrace] } - set result "Runtime Error: $error" - foreach {l f p} [lreverse $stacktrace] { - append result \n - if {$p ne ""} { - append result "in procedure '$p' " - if {$f ne ""} { - append result "called " - } - } - if {$f ne ""} { - append result "at file \"$f\", line $l" - } - } - if {[info exists f] && $f ne ""} { - return "$f:$l: $result" + lassign $stacktrace p f l + if {$f ne ""} { + set result "$f:$l " } - return $result + append result "Runtime Error: $error\n" + append result [stackdump $stacktrace] } proc {info nameofexecutable} {} { |