summaryrefslogtreecommitdiffstats
path: root/generic/tclCompile.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCompile.c')
-rw-r--r--generic/tclCompile.c178
1 files changed, 177 insertions, 1 deletions
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 7781066..d40af69 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.192 2010/10/20 13:34:11 dkf Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.193 2010/10/20 20:52:27 ferrieux Exp $
*/
#include "tclInt.h"
@@ -452,6 +452,8 @@ static int FormatInstruction(ByteCode *codePtr,
const unsigned char *pc, Tcl_Obj *bufferObj);
static void PrintSourceToObj(Tcl_Obj *appendObj,
const char *stringPtr, int maxChars);
+static void UpdateStringOfInstName(Tcl_Obj *objPtr);
+
/*
* TIP #280: Helper for building the per-word line information of all compiled
* commands.
@@ -486,6 +488,19 @@ static const Tcl_ObjType substCodeType = {
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
};
+
+/*
+ * The structure below defines an instruction name Tcl object to allow
+ * reporting of inner contexts in errorstack without string allocation.
+ */
+
+static const Tcl_ObjType tclInstNameType = {
+ "instname", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ UpdateStringOfInstName, /* updateStringProc */
+ NULL, /* setFromAnyProc */
+};
/*
*----------------------------------------------------------------------
@@ -4238,6 +4253,165 @@ FormatInstruction(
/*
*----------------------------------------------------------------------
*
+ * TclGetInnerContext --
+ *
+ * If possible, returns a list capturing the inner context. Otherwise
+ * return NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp,
+ const unsigned char *pc,
+ Tcl_Obj **tosPtr)
+{
+ int objc = 0, off = 0;
+ Tcl_Obj *result;
+ Interp *iPtr = (Interp *) interp;
+
+ switch(*pc) {
+
+ case INST_STR_LEN:
+ case INST_LNOT:
+ case INST_BITNOT:
+ case INST_UMINUS:
+ case INST_UPLUS:
+ case INST_TRY_CVT_TO_NUMERIC:
+ case INST_EXPAND_STKTOP:
+ case INST_EXPR_STK:
+
+ objc = 1;
+ break;
+
+ case INST_LIST_IN:
+ case INST_LIST_NOT_IN: /* Basic list containment operators. */
+ case INST_STR_EQ:
+ case INST_STR_NEQ: /* String (in)equality check */
+ case INST_STR_CMP: /* String compare. */
+ case INST_STR_INDEX:
+ case INST_STR_MATCH:
+ case INST_REGEXP:
+ case INST_EQ:
+ case INST_NEQ:
+ case INST_LT:
+ case INST_GT:
+ case INST_LE:
+ case INST_GE:
+ case INST_MOD:
+ case INST_LSHIFT:
+ case INST_RSHIFT:
+ case INST_BITOR:
+ case INST_BITXOR:
+ case INST_BITAND:
+ case INST_EXPON:
+ case INST_ADD:
+ case INST_SUB:
+ case INST_DIV:
+ case INST_MULT:
+ objc = 2;
+ break;
+
+ case INST_RETURN_STK:
+ /* early pop. TODO: dig out opt dict too :/ */
+ objc = 1;
+ break;
+
+ case INST_SYNTAX:
+ case INST_RETURN_IMM:
+ objc = 2;
+ break;
+
+ case INST_INVOKE_STK4:
+ objc = TclGetUInt4AtPtr(pc+1);
+ break;
+
+ case INST_INVOKE_STK1:
+ objc = TclGetUInt1AtPtr(pc+1);
+ break;
+ }
+
+ result = iPtr->innerContext;
+ if (Tcl_IsShared(result)) {
+ Tcl_DecrRefCount(result);
+ iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL);
+ Tcl_IncrRefCount(result);
+ } else {
+ int len;
+
+ Tcl_ListObjLength(interp, result, &len);
+ /* reset while keeping the list intrep as much as possible */
+ Tcl_ListObjReplace(interp, result, 0, len, 0, NULL);
+ }
+ Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc));
+ for(;objc>0;objc--) {
+ Tcl_Obj *ob;
+
+ ob = tosPtr[1 - objc + off];
+ if (!ob) {
+ Tcl_Panic("InnerContext: bad tos -- appending null object");
+ }
+ if (ob->refCount<=0 || ob->refCount==0x61616161) {
+ Tcl_Panic("InnerContext: bad tos -- appending freed object %p",ob);
+ }
+ Tcl_ListObjAppendElement(NULL, result, ob);
+ }
+
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNewInstNameObj --
+ *
+ * Creates a new InstName Tcl_Obj based on the given instruction
+ *
+ *----------------------------------------------------------------------
+ */
+MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst)
+{
+ Tcl_Obj *objPtr;
+
+ objPtr=Tcl_NewObj();
+ objPtr->typePtr = &tclInstNameType;
+ objPtr->internalRep.longValue = (long)inst;
+ objPtr->bytes = NULL;
+
+ return objPtr;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfInstName --
+ *
+ * Update the string representation for an instruction name object.
+ *
+ *----------------------------------------------------------------------
+ */
+static void UpdateStringOfInstName(Tcl_Obj *objPtr)
+{
+ int inst = objPtr->internalRep.longValue;
+ char *s,buf[20];
+ int len;
+
+ if ((inst < 0) || (inst > LAST_INST_OPCODE)) {
+
+ sprintf(buf, "inst_%d", inst);
+ s = buf;
+ } else {
+ s = (char *)tclInstructionTable[objPtr->internalRep.longValue].name;
+ }
+ len = strlen(s);
+ objPtr->bytes = ckalloc((unsigned) len + 1);
+ strcpy(objPtr->bytes, s);
+ objPtr->length = len;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
* PrintSourceToObj --
*
* Appends a quoted representation of a string to a Tcl_Obj.
@@ -4343,5 +4517,7 @@ RecordByteCodeStats(
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
* End:
*/