summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog7
-rw-r--r--generic/tclAssembly.c125
-rw-r--r--generic/tclAssembly.h23
-rw-r--r--tests/assemble.test437
4 files changed, 514 insertions, 78 deletions
diff --git a/ChangeLog b/ChangeLog
index a362cbf..0fec7d6 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2010-09-30 Kevin B, Kenny <kennykb@acm.org>
+
+ [dogeen-assembler-branch]
+
+ * tests/assemble.test: Added tryCvtToNumeric and several more list
+ * generic/tclAssemble.c: operations.
+
2010-09-29 Kevin B. Kenny <kennykb@acm.org>
[dogeen-assembler-branch]
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index d6916fa..cac051f 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -32,6 +32,7 @@ static int FinishAssembly(AssembleEnv*);
static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr);
static void FreeAssembleEnv(AssembleEnv*);
static int GetBooleanOperand(AssembleEnv*, Tcl_Token**, int*);
+static int GetListIndexOperand(AssembleEnv*, Tcl_Token**, int*);
static int GetIntegerOperand(AssembleEnv*, Tcl_Token**, int*);
static int GetNextOperand(AssembleEnv*, Tcl_Token**, Tcl_Obj**);
static AssembleEnv* NewAssembleEnv(CompileEnv*, int);
@@ -173,11 +174,19 @@ TalInstDesc TalInstructionTable[] = {
ASSEM_1BYTE, INST_LAPPEND_STK,
2, 1},
{"le", ASSEM_1BYTE , INST_LE , 2 , 1},
+ {"lindexMulti",
+ ASSEM_LINDEX_MULTI,
+ INST_LIST_INDEX_MULTI,
+ INT_MIN,1},
+ {"list", ASSEM_LIST, INST_LIST, INT_MIN,1},
{"listIndex",
ASSEM_1BYTE, INST_LIST_INDEX,2, 1},
+ {"listIndexImm",
+ ASSEM_INDEX, INST_LIST_INDEX_IMM,
+ 1, 1},
{"listLength",
ASSEM_1BYTE, INST_LIST_LENGTH,
- 1, 1},
+ 1, 1},
{"load", ASSEM_LVT, (INST_LOAD_SCALAR1 << 8
| INST_LOAD_SCALAR4),
0, 1},
@@ -191,6 +200,8 @@ TalInstDesc TalInstructionTable[] = {
{"loadStk", ASSEM_1BYTE, INST_LOAD_SCALAR_STK,
1, 1},
{"lor", ASSEM_1BYTE , INST_LOR , 2 , 1},
+ {"lsetFlat",
+ ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1},
{"lsetList",
ASSEM_1BYTE, INST_LSET_LIST, 3, 1},
{"lshift", ASSEM_1BYTE , INST_LSHIFT , 2 , 1},
@@ -225,6 +236,9 @@ TalInstDesc TalInstructionTable[] = {
ASSEM_BOOL, INST_STR_MATCH, 2, 1},
{"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1},
{"sub", ASSEM_1BYTE , INST_SUB , 2 , 1},
+ {"tryCvtToNumeric",
+ ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,
+ 1, 1},
{"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1},
{"unset", ASSEM_BOOL_LVT4,
INST_UNSET_SCALAR,
@@ -1117,6 +1131,60 @@ AssembleOneLine(AssembleEnv* assemEnvPtr)
}
break;
+ case ASSEM_LINDEX_MULTI:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
+ goto cleanup;
+ }
+ if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
+ || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
+ goto cleanup;
+ }
+ BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd);
+ break;
+
+ case ASSEM_LIST:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
+ goto cleanup;
+ }
+ if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
+ || CheckNonNegative(interp, opnd) != TCL_OK) {
+ goto cleanup;
+ }
+ BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd);
+ break;
+
+ case ASSEM_INDEX:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
+ goto cleanup;
+ }
+ if (GetListIndexOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
+ goto cleanup;
+ }
+ BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd);
+ break;
+
+ case ASSEM_LSET_FLAT:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
+ goto cleanup;
+ }
+ if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
+ goto cleanup;
+ }
+ if (opnd < 2) {
+ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("operand must be >=2", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", NULL);
+ }
+ goto cleanup;
+ }
+ BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd);
+ break;
+
case ASSEM_LVT:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
@@ -1378,6 +1446,61 @@ GetIntegerOperand(AssembleEnv* assemEnvPtr,
/*
*-----------------------------------------------------------------------------
*
+ * GetListIndexOperand --
+ *
+ * Gets the value of an operand intended to serve as a list index.
+ *
+ * Results:
+ * Returns a standard Tcl result: TCL_OK if the parse is successful
+ * and TCL_ERROR (with an appropriate error message) if the parse fails.
+ *
+ * Side effects:
+ * Stores the list index at '*index'. Values between -1 and 0x7fffffff
+ * have their natural meaning; values between -2 and -0x80000000
+ * represent 'end-2-N'.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+GetListIndexOperand(
+ AssembleEnv* assemEnvPtr,
+ /* Assembly environment */
+ Tcl_Token** tokenPtrPtr,
+ /* Current token from the parser */
+ int* result)
+ /* OUTPUT: Integer extracted from the token */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ Tcl_Token* tokenPtr = *tokenPtrPtr;
+ /* INOUT: Pointer to the next token
+ * in the source code */
+ Tcl_Obj* intObj = Tcl_NewObj();
+ /* Integer from the source code */
+ int status; /* Tcl status return */
+
+ /* Extract the next token as a string */
+
+ Tcl_IncrRefCount(intObj);
+ if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
+ Tcl_DecrRefCount(intObj);
+ return TCL_ERROR;
+ }
+
+ /* Convert to an integer, advance to the next token and return */
+
+ status = TclGetIntForIndex(interp, intObj, -2, result);
+ Tcl_DecrRefCount(intObj);
+ *tokenPtrPtr = TokenAfter(tokenPtr);
+ return status;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
* FindLocalVar --
*
* Gets the name of a local variable from the input stream and advances
diff --git a/generic/tclAssembly.h b/generic/tclAssembly.h
index 6ea9137..c950dd8 100644
--- a/generic/tclAssembly.h
+++ b/generic/tclAssembly.h
@@ -43,25 +43,34 @@ typedef struct BasicBlock {
typedef enum TalInstType {
- ASSEM_1BYTE, /* The instructions that are directly mapped to tclInstructionTable in tclCompile.c*/
+ ASSEM_1BYTE, /* Fixed arity, 1-byte instruction */
ASSEM_BOOL, /* One Boolean operand */
ASSEM_BOOL_LVT4,/* One Boolean, one 4-byte LVT ref. */
- ASSEM_CONCAT1, /* One 1-byte unsigned-integer operand count (CONCAT1) */
+ ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must be
+ * strictly positive, consumes N, produces 1 */
ASSEM_EVAL, /* 'eval' - evaluate a constant script (by compiling it
* in line with the assembly code! I love Tcl!) */
- ASSEM_INVOKE, /* Command invocation, 1- or 4-byte unsigned operand
- * count */
+ ASSEM_INDEX, /* 4 byte operand, integer or end-integer */
+ ASSEM_INVOKE, /* 1- or 4-byte operand count, must be strictly positive,
+ * consumes N, produces 1. */
ASSEM_JUMP, /* Jump instructions */
ASSEM_LABEL, /* The assembly directive that defines a label */
+ ASSEM_LINDEX_MULTI,
+ /* 4-byte operand count, must be strictly positive,
+ * consumes N, produces 1 */
+ ASSEM_LIST, /* 4-byte operand count, must be nonnegative, consumses N,
+ * produces 1 */
+ ASSEM_LSET_FLAT,/* 4-byte operand count, must be >= 3, consumes N,
+ * produces 1 */
ASSEM_LVT, /* One operand that references a local variable */
ASSEM_LVT1, /* One 1-byte operand that references a local variable */
ASSEM_LVT1_SINT1,
/* One 1-byte operand that references a local variable,
* one signed-integer 1-byte operand */
ASSEM_LVT4, /* One 4-byte operand that references a local variable */
- ASSEM_OVER, /* OVER: consumes n+1 operands and produces n+2 */
- ASSEM_PUSH, /* These instructions will be looked up from talInstructionTable */
- ASSEM_REVERSE, /* REVERSE: consumes n operands and produces n */
+ ASSEM_OVER, /* OVER: 4-byte operand count, consumes N+1, produces N+2 */
+ ASSEM_PUSH, /* one literal operand */
+ ASSEM_REVERSE, /* REVERSE: 4-byte operand count, consumes N, produces N */
ASSEM_SINT1, /* One 1-byte signed-integer operand (INCR_STK_IMM) */
} TalInstType;
diff --git a/tests/assemble.test b/tests/assemble.test
index 03f329a..bff1a84 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -779,7 +779,24 @@ test assemble-7.38 {sub} {
-result 25
}
-test assemble-7.39 {uminus} {
+test assemble-7.39 {tryCvtToNumeric} {
+ -body {
+ assemble {
+ push 42; tryCvtToNumeric
+ }
+ }
+ -result 42
+}
+test assemble-7.43 {tryCvtToNumeric} {
+ -body {
+ assemble {
+ push NaN; tryCvtToNumeric
+ }
+ }
+ -returnCodes error
+ -result {domain error: argument not in valid range}
+}
+test assemble-7.41 {uminus} {
-body {
assemble {
push 42; uminus
@@ -788,7 +805,7 @@ test assemble-7.39 {uminus} {
-result -42
}
-test assemble-7.40 {uplus} {
+test assemble-7.42 {uplus} {
-body {
assemble {
push 42; uplus
@@ -796,6 +813,15 @@ test assemble-7.40 {uplus} {
}
-result 42
}
+test assemble-7.43 {uplus} {
+ -body {
+ assemble {
+ push NaN; uplus
+ }
+ }
+ -returnCodes error
+ -result {can't use non-numeric floating-point value as operand of "+"}
+}
# assemble-8 ASSEM_LVT and FindLocalVar
@@ -1507,9 +1533,67 @@ test assemble-14.7 {incrArrayStkImm} {
-cleanup {rename x {}}
}
-# assemble-15 - invokeStk
+# assemble-15 - listIndexImm
+
+test assemble-15.1 {listIndexImm - wrong # args} {
+ -body {
+ assemble {listIndexImm}
+ }
+ -returnCodes error
+ -match glob
+ -result {wrong # args*}
+}
-test assemble-15.1 {invokeStk - wrong # args} {
+test assemble-16.2 {listIndexImm - wrong # args} {
+ -body {
+ assemble {listIndexImm too many}
+ }
+ -returnCodes error
+ -match glob
+ -result {wrong # args*}
+}
+
+test assemble-16.3 {listIndexImm - bad substitution} {
+ -body {
+ list [catch {assemble {listIndexImm $foo}} result] $result $::errorCode
+ }
+ -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
+ -cleanup {unset result}
+}
+
+test assemble-16.4 {listIndexImm - invalid index} {
+ -body {
+ assemble {listIndexImm rubbish}
+ }
+ -returnCodes error
+ -match glob
+ -result {bad index "rubbish"*}
+}
+
+test assemble-16.5 {listIndexImm} {
+ -body {
+ assemble {push {a b c}; listIndexImm 2}
+ }
+ -result c
+}
+
+test assemble-16.6 {listIndexImm} {
+ -body {
+ assemble {push {a b c}; listIndexImm end-1}
+ }
+ -result b
+}
+
+test assemble-16.6 {listIndexImm} {
+ -body {
+ assemble {push {a b c}; listIndexImm end}
+ }
+ -result c
+}
+
+# assemble-16 - invokeStk
+
+test assemble-16.1 {invokeStk - wrong # args} {
-body {
assemble {invokeStk}
}
@@ -1518,7 +1602,7 @@ test assemble-15.1 {invokeStk - wrong # args} {
-result {wrong # args*}
}
-test assemble-15.2 {invokeStk - wrong # args} {
+test assemble-16.2 {invokeStk - wrong # args} {
-body {
assemble {invokeStk too many}
}
@@ -1527,7 +1611,7 @@ test assemble-15.2 {invokeStk - wrong # args} {
-result {wrong # args*}
}
-test assemble-15.3 {invokeStk - not a number} {
+test assemble-16.3 {invokeStk - not a number} {
-body {
proc x {} {
assemble {invokeStk rubbish}
@@ -1539,7 +1623,7 @@ test assemble-15.3 {invokeStk - not a number} {
-cleanup {rename x {}}
}
-test assemble-15.4 {invokeStk - no operands} {
+test assemble-16.4 {invokeStk - no operands} {
-body {
proc x {} {
assemble {invokeStk 0}
@@ -1550,14 +1634,14 @@ test assemble-15.4 {invokeStk - no operands} {
-cleanup {rename x {}; unset result}
}
-test assemble-15.5 {invokeStk1} {
+test assemble-16.5 {invokeStk1} {
-body {
tcl::unsupported::assemble {push concat; push 1; push 2; invokeStk 3}
}
-result {1 2}
}
-test assemble-15.6 {invokeStk4} {
+test assemble-16.6 {invokeStk4} {
-body {
proc x {n} {
set code {push concat}
@@ -1576,9 +1660,9 @@ test assemble-15.6 {invokeStk4} {
-cleanup {rename x {}}
}
-# assemble-16 -- jumps and labels
+# assemble-17 -- jumps and labels
-test assemble-16.1 {label, wrong # args} {
+test assemble-17.1 {label, wrong # args} {
-body {
assemble {label}
}
@@ -1587,7 +1671,7 @@ test assemble-16.1 {label, wrong # args} {
-result {wrong # args*}
}
-test assemble-16.2 {label, wrong # args} {
+test assemble-17.2 {label, wrong # args} {
-body {
assemble {label too many}
}
@@ -1596,7 +1680,7 @@ test assemble-16.2 {label, wrong # args} {
-result {wrong # args*}
}
-test assemble-16.3 {label, bad subst} {
+test assemble-17.3 {label, bad subst} {
-body {
list [catch {assemble {label $foo}} result] $result $::errorCode
}
@@ -1604,7 +1688,7 @@ test assemble-16.3 {label, bad subst} {
-cleanup {unset result}
}
-test assemble-16.4 {duplicate label} {
+test assemble-17.4 {duplicate label} {
-body {
list [catch {assemble {label foo; label foo}} result] \
$result $::errorCode
@@ -1612,7 +1696,7 @@ test assemble-16.4 {duplicate label} {
-result {1 {duplicate definition of label "foo"} {TCL ASSEM DUPLABEL foo}}
}
-test assemble-16.5 {jump, wrong # args} {
+test assemble-17.5 {jump, wrong # args} {
-body {
assemble {jump}
}
@@ -1621,7 +1705,7 @@ test assemble-16.5 {jump, wrong # args} {
-result {wrong # args*}
}
-test assemble-16.6 {jump, wrong # args} {
+test assemble-17.6 {jump, wrong # args} {
-body {
assemble {jump too many}
}
@@ -1630,7 +1714,7 @@ test assemble-16.6 {jump, wrong # args} {
-result {wrong # args*}
}
-test assemble-16.7 {jump, bad subst} {
+test assemble-17.7 {jump, bad subst} {
-body {
list [catch {assemble {jump $foo}} result] $result $::errorCode
}
@@ -1638,7 +1722,7 @@ test assemble-16.7 {jump, bad subst} {
-cleanup {unset result}
}
-test assemble-16.8 {jump - ahead and back} {
+test assemble-17.8 {jump - ahead and back} {
-body {
assemble {
jump three
@@ -1671,7 +1755,7 @@ test assemble-16.8 {jump - ahead and back} {
-result ceadbf
}
-test assemble-16.9 {jump - resolve a label multiple times} {
+test assemble-17.9 {jump - resolve a label multiple times} {
-body {
proc x {} {
set case 0
@@ -1739,7 +1823,7 @@ test assemble-16.9 {jump - resolve a label multiple times} {
-cleanup {rename x {}}
}
-test assemble-16.10 {jump4} {
+test assemble-17.10 {jump4} {
-body {
assemble "push x; jump one; label two; [string repeat {dup; pop;} 128]
jump three; label one; jump two; label three"
@@ -1747,7 +1831,7 @@ test assemble-16.10 {jump4} {
-result x
}
-test assemble-16.11 {jumpTrue} {
+test assemble-17.11 {jumpTrue} {
-body {
proc x {y} {
assemble {
@@ -1766,7 +1850,7 @@ test assemble-16.11 {jumpTrue} {
-cleanup {rename x {}}
}
-test assemble-16.12 {jumpFalse} {
+test assemble-17.12 {jumpFalse} {
-body {
proc x {y} {
assemble {
@@ -1785,14 +1869,14 @@ test assemble-16.12 {jumpFalse} {
-cleanup {rename x {}}
}
-test assemble-16.13 {jump to undefined label} {
+test assemble-17.13 {jump to undefined label} {
-body {
list [catch {assemble {jump nowhere}} result] $result $::errorCode
}
-result {1 {undefined label "nowhere"} {TCL ASSEM NOLABEL nowhere}}
}
-test assemble-16.14 {jump to undefined label, line number correct?} {
+test assemble-17.14 {jump to undefined label, line number correct?} {
-body {
catch {assemble {#1
#2
@@ -1807,9 +1891,221 @@ test assemble-16.14 {jump to undefined label, line number correct?} {
-result {*"assemble" body, line 4*}
}
-# assemble-17 - over
+# assemble-18 - lindexMulti
+
+test assemble-18.1 {lindexMulti - wrong # args} {
+ -body {
+ assemble {lindexMulti}
+ }
+ -returnCodes error
+ -match glob
+ -result {wrong # args*}
+}
+
+test assemble-18.2 {lindexMulti - wrong # args} {
+ -body {
+ assemble {lindexMulti too many}
+ }
+ -returnCodes error
+ -match glob
+ -result {wrong # args*}
+}
+
+test assemble-18.3 {lindexMulti - bad subst} {
+ -body {
+ assemble {lindexMulti $foo}
+ }
+ -returnCodes error
+ -match glob
+ -result {assembly code may not contain substitutions}
+}
+
+test assemble-18.4 {lindexMulti - not a number} {
+ -body {
+ proc x {} {
+ assemble {lindexMulti rubbish}
+ }
+ x
+ }
+ -returnCodes error
+ -result {expected integer but got "rubbish"}
+ -cleanup {rename x {}}
+}
+
+test assemble-18.5 {lindexMulti - bad operand count} {
+ -body {
+ proc x {} {
+ assemble {lindexMulti 0}
+ }
+ list [catch x result] $result $::errorCode
+ }
+ -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
+ -cleanup {rename x {}; unset result}
+}
+
+test assemble-18.6 {lindexMulti} {
+ -body {
+ assemble {push {{a b c} {d e f} {g h j}}; lindexMulti 1}
+ }
+ -result {{a b c} {d e f} {g h j}}
+}
-test assemble-17.1 {over - wrong # args} {
+test assemble-18.7 {lindexMulti} {
+ -body {
+ assemble {push {{a b c} {d e f} {g h j}}; push 1; lindexMulti 2}
+ }
+ -result {d e f}
+}
+
+test assemble-18.8 {lindexMulti} {
+ -body {
+ assemble {push {{a b c} {d e f} {g h j}}; push 2; push 1; lindexMulti 3}
+ }
+ -result h
+}
+
+# assemble-19 - list
+
+test assemble-19.1 {list - wrong # args} {
+ -body {
+ assemble {list}
+ }
+ -returnCodes error
+ -match glob
+ -result {wrong # args*}
+}
+
+test assemble-19.2 {list - wrong # args} {
+ -body {
+ assemble {list too many}
+ }
+ -returnCodes error
+ -match glob
+ -result {wrong # args*}
+}
+
+test assemble-19.3 {list - bad subst} {
+ -body {
+ assemble {list $foo}
+ }
+ -returnCodes error
+ -match glob
+ -result {assembly code may not contain substitutions}
+}
+
+test assemble-19.4 {list - not a number} {
+ -body {
+ proc x {} {
+ assemble {list rubbish}
+ }
+ x
+ }
+ -returnCodes error
+ -result {expected integer but got "rubbish"}
+ -cleanup {rename x {}}
+}
+
+test assemble-19.5 {list - negative operand count} {
+ -body {
+ proc x {} {
+ assemble {list -1}
+ }
+ list [catch x result] $result $::errorCode
+ }
+ -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}}
+ -cleanup {rename x {}; unset result}
+}
+
+test assemble-19.6 {list - no args} {
+ -body {
+ assemble {list 0}
+ }
+ -result {}
+}
+
+test assemble-19.7 {list - 1 arg} {
+ -body {
+ assemble {push hello; list 1}
+ }
+ -result hello
+}
+
+test assemble-19.8 {list - 2 args} {
+ -body {
+ assemble {push hello; push world; list 2}
+ }
+ -result {hello world}
+}
+
+# assemble-20 - lsetFlat
+
+test assemble-20.1 {lsetFlat - wrong # args} {
+ -body {
+ assemble {lsetFlat}
+ }
+ -returnCodes error
+ -match glob
+ -result {wrong # args*}
+}
+
+test assemble-20.2 {lsetFlat - wrong # args} {
+ -body {
+ assemble {lsetFlat too many}
+ }
+ -returnCodes error
+ -match glob
+ -result {wrong # args*}
+}
+
+test assemble-20.3 {lsetFlat - bad subst} {
+ -body {
+ assemble {lsetFlat $foo}
+ }
+ -returnCodes error
+ -match glob
+ -result {assembly code may not contain substitutions}
+}
+
+test assemble-20.4 {lsetFlat - not a number} {
+ -body {
+ proc x {} {
+ assemble {lsetFlat rubbish}
+ }
+ x
+ }
+ -returnCodes error
+ -result {expected integer but got "rubbish"}
+ -cleanup {rename x {}}
+}
+
+test assemble-20.5 {lsetFlat - negative operand count} {
+ -body {
+ proc x {} {
+ assemble {lsetFlat 1}
+ }
+ list [catch x result] $result $::errorCode
+ }
+ -result {1 {operand must be >=2} {TCL ASSEM OPERAND>=2}}
+ -cleanup {rename x {}; unset result}
+}
+
+test assemble-20.6 {lsetFlat} {
+ -body {
+ assemble {push b; push a; lsetFlat 2}
+ }
+ -result b
+}
+
+test assemble-20.7 {lsetFlat} {
+ -body {
+ assemble {push 1; push d; push {a b c}; lsetFlat 3}
+ }
+ -result {a d c}
+}
+
+# assemble-21 - over
+
+test assemble-21.1 {over - wrong # args} {
-body {
assemble {over}
}
@@ -1818,7 +2114,7 @@ test assemble-17.1 {over - wrong # args} {
-result {wrong # args*}
}
-test assemble-17.2 {over - wrong # args} {
+test assemble-21.2 {over - wrong # args} {
-body {
assemble {over too many}
}
@@ -1827,7 +2123,7 @@ test assemble-17.2 {over - wrong # args} {
-result {wrong # args*}
}
-test assemble-17.3 {over - bad subst} {
+test assemble-21.3 {over - bad subst} {
-body {
assemble {over $foo}
}
@@ -1836,7 +2132,7 @@ test assemble-17.3 {over - bad subst} {
-result {assembly code may not contain substitutions}
}
-test assemble-17.4 {over - not a number} {
+test assemble-21.4 {over - not a number} {
-body {
proc x {} {
assemble {over rubbish}
@@ -1848,7 +2144,7 @@ test assemble-17.4 {over - not a number} {
-cleanup {rename x {}}
}
-test assemble-17.5 {over - negative operand count} {
+test assemble-21.5 {over - negative operand count} {
-body {
proc x {} {
assemble {over -1}
@@ -1859,7 +2155,7 @@ test assemble-17.5 {over - negative operand count} {
-cleanup {rename x {}; unset result}
}
-test assemble-17.6 {over} {
+test assemble-21.6 {over} {
-body {
proc x {} {
assemble {
@@ -1881,7 +2177,7 @@ test assemble-17.6 {over} {
-cleanup {rename x {}}
}
-test assemble-17.7 {over} {
+test assemble-21.7 {over} {
-body {
proc x {} {
assemble {
@@ -1903,9 +2199,9 @@ test assemble-17.7 {over} {
-cleanup {rename x {}}
}
-# assemble-18 - reverse
+# assemble-22 - reverse
-test assemble-18.1 {reverse - wrong # args} {
+test assemble-22.1 {reverse - wrong # args} {
-body {
assemble {reverse}
}
@@ -1914,7 +2210,7 @@ test assemble-18.1 {reverse - wrong # args} {
-result {wrong # args*}
}
-test assemble-18.2 {reverse - wrong # args} {
+test assemble-22.2 {reverse - wrong # args} {
-body {
assemble {reverse too many}
}
@@ -1923,7 +2219,7 @@ test assemble-18.2 {reverse - wrong # args} {
-result {wrong # args*}
}
-test assemble-18.3 {reverse - bad subst} {
+test assemble-22.3 {reverse - bad subst} {
-body {
assemble {reverse $foo}
}
@@ -1932,7 +2228,7 @@ test assemble-18.3 {reverse - bad subst} {
-result {assembly code may not contain substitutions}
}
-test assemble-18.4 {reverse - not a number} {
+test assemble-22.4 {reverse - not a number} {
-body {
proc x {} {
assemble {reverse rubbish}
@@ -1944,7 +2240,7 @@ test assemble-18.4 {reverse - not a number} {
-cleanup {rename x {}}
}
-test assemble-18.5 {reverse - negative operand count} {
+test assemble-22.5 {reverse - negative operand count} {
-body {
proc x {} {
assemble {reverse -1}
@@ -1955,7 +2251,7 @@ test assemble-18.5 {reverse - negative operand count} {
-cleanup {rename x {}; unset result}
}
-test assemble-18.6 {reverse - zero operand count} {
+test assemble-22.6 {reverse - zero operand count} {
-body {
proc x {} {
assemble {push 1; reverse 0}
@@ -1966,7 +2262,7 @@ test assemble-18.6 {reverse - zero operand count} {
-cleanup {rename x {}}
}
-test assemble-18.7 {reverse} {
+test assemble-22.7 {reverse} {
-body {
proc x {} {
assemble {
@@ -1987,7 +2283,7 @@ test assemble-18.7 {reverse} {
-cleanup {rename x {}}
}
-test assemble-18.8 {reverse} {
+test assemble-22.8 {reverse} {
-body {
proc x {} {
assemble {
@@ -2008,9 +2304,9 @@ test assemble-18.8 {reverse} {
-cleanup {rename x {}}
}
-# assemble-19 - ASSEM_BOOL (strmatch, unsetStk, unsetArrayStk)
+# assemble-23 - ASSEM_BOOL (strmatch, unsetStk, unsetArrayStk)
-test assemble-19.1 {strmatch - wrong # args} {
+test assemble-23.1 {strmatch - wrong # args} {
-body {
assemble {strmatch}
}
@@ -2019,7 +2315,7 @@ test assemble-19.1 {strmatch - wrong # args} {
-result {wrong # args*}
}
-test assemble-19.2 {strmatch - wrong # args} {
+test assemble-23.2 {strmatch - wrong # args} {
-body {
assemble {strmatch too many}
}
@@ -2028,7 +2324,7 @@ test assemble-19.2 {strmatch - wrong # args} {
-result {wrong # args*}
}
-test assemble-19.3 {strmatch - bad subst} {
+test assemble-23.3 {strmatch - bad subst} {
-body {
assemble {strmatch $foo}
}
@@ -2037,7 +2333,7 @@ test assemble-19.3 {strmatch - bad subst} {
-result {assembly code may not contain substitutions}
}
-test assemble-18.4 {strmatch - not a boolean} {
+test assemble-23.4 {strmatch - not a boolean} {
-body {
proc x {} {
assemble {strmatch rubbish}
@@ -2049,7 +2345,7 @@ test assemble-18.4 {strmatch - not a boolean} {
-cleanup {rename x {}}
}
-test assemble-18.5 {strmatch} {
+test assemble-23.5 {strmatch} {
-body {
proc x {a b} {
list [assemble {load a; load b; strmatch 0}] \
@@ -2061,7 +2357,7 @@ test assemble-18.5 {strmatch} {
-cleanup {rename x {}}
}
-test assemble-18.6 {unsetStk} {
+test assemble-23.6 {unsetStk} {
-body {
proc x {} {
set a {}
@@ -2074,7 +2370,7 @@ test assemble-18.6 {unsetStk} {
-cleanup {rename x {}}
}
-test assemble-18.7 {unsetStk} {
+test assemble-23.7 {unsetStk} {
-body {
proc x {} {
assemble {push a; unsetStk false}
@@ -2085,7 +2381,7 @@ test assemble-18.7 {unsetStk} {
-result 0
-cleanup {rename x {}}
}
-test assemble-18.8 {unsetStk} {
+test assemble-23.8 {unsetStk} {
-body {
proc x {} {
assemble {push a; unsetStk true}
@@ -2098,7 +2394,7 @@ test assemble-18.8 {unsetStk} {
-cleanup {rename x {}}
}
-test assemble-18.9 {unsetArrayStk} {
+test assemble-23.9 {unsetArrayStk} {
-body {
proc x {} {
set a(b) {}
@@ -2111,7 +2407,7 @@ test assemble-18.9 {unsetArrayStk} {
-cleanup {rename x {}}
}
-test assemble-18.10 {unsetArrayStk} {
+test assemble-23.10 {unsetArrayStk} {
-body {
proc x {} {
assemble {push a; push b; unsetArrayStk false}
@@ -2122,7 +2418,7 @@ test assemble-18.10 {unsetArrayStk} {
-result 0
-cleanup {rename x {}}
}
-test assemble-18.11 {unsetArrayStk} {
+test assemble-23.11 {unsetArrayStk} {
-body {
proc x {} {
assemble {push a; push b; unsetArrayStk true}
@@ -2135,9 +2431,9 @@ test assemble-18.11 {unsetArrayStk} {
-cleanup {rename x {}}
}
-# assemble-19 -- ASSEM_BOOL_LVT4 (unset; unsetArray)
+# assemble-24 -- ASSEM_BOOL_LVT4 (unset; unsetArray)
-test assemble-19.1 {unset - wrong # args} {
+test assemble-24.1 {unset - wrong # args} {
-body {
assemble {unset one}
}
@@ -2146,7 +2442,7 @@ test assemble-19.1 {unset - wrong # args} {
-result {wrong # args*}
}
-test assemble-19.2 {unset - wrong # args} {
+test assemble-24.2 {unset - wrong # args} {
-body {
assemble {unset too many args}
}
@@ -2155,7 +2451,7 @@ test assemble-19.2 {unset - wrong # args} {
-result {wrong # args*}
}
-test assemble-19.3 {unset - bad subst -arg 1} {
+test assemble-24.3 {unset - bad subst -arg 1} {
-body {
assemble {unset $foo bar}
}
@@ -2164,7 +2460,7 @@ test assemble-19.3 {unset - bad subst -arg 1} {
-result {assembly code may not contain substitutions}
}
-test assemble-19.4 {unset - not a boolean} {
+test assemble-24.4 {unset - not a boolean} {
-body {
proc x {} {
assemble {unset rubbish trash}
@@ -2176,7 +2472,7 @@ test assemble-19.4 {unset - not a boolean} {
-cleanup {rename x {}}
}
-test assemble-19.5 {unset - bad subst - arg 2} {
+test assemble-24.5 {unset - bad subst - arg 2} {
-body {
assemble {unset true $bar}
}
@@ -2184,7 +2480,7 @@ test assemble-19.5 {unset - bad subst - arg 2} {
-result {assembly code may not contain substitutions}
}
-test assemble-19.6 {unset - nonlocal var} {
+test assemble-24.6 {unset - nonlocal var} {
-body {
assemble {unset true ::foo::bar}
}
@@ -2192,7 +2488,7 @@ test assemble-19.6 {unset - nonlocal var} {
-result {variable "::foo::bar" is not local}
}
-test assemble-19.7 {unset} {
+test assemble-24.7 {unset} {
-body {
proc x {} {
set a {}
@@ -2205,7 +2501,7 @@ test assemble-19.7 {unset} {
-cleanup {rename x {}}
}
-test assemble-19.8 {unset} {
+test assemble-24.8 {unset} {
-body {
proc x {} {
assemble {unset false a}
@@ -2216,7 +2512,7 @@ test assemble-19.8 {unset} {
-result 0
-cleanup {rename x {}}
}
-test assemble-19.9 {unset} {
+test assemble-24.9 {unset} {
-body {
proc x {} {
assemble {unset true a}
@@ -2229,7 +2525,7 @@ test assemble-19.9 {unset} {
-cleanup {rename x {}}
}
-test assemble-19.10 {unsetArray} {
+test assemble-24.10 {unsetArray} {
-body {
proc x {} {
set a(b) {}
@@ -2242,7 +2538,7 @@ test assemble-19.10 {unsetArray} {
-cleanup {rename x {}}
}
-test assemble-19.11 {unsetArray} {
+test assemble-24.11 {unsetArray} {
-body {
proc x {} {
assemble {push b; unsetArray false a}
@@ -2253,7 +2549,8 @@ test assemble-19.11 {unsetArray} {
-result 0
-cleanup {rename x {}}
}
-test assemble-19.12 {unsetArray} {
+
+test assemble-24.12 {unsetArray} {
-body {
proc x {} {
assemble {push b; unsetArray true a}
@@ -2266,7 +2563,7 @@ test assemble-19.12 {unsetArray} {
-cleanup {rename x {}}
}
-test assemble-20.1 {unbalanced stack} {
+test assemble-30.1 {unbalanced stack} {
-body {
list \
[catch {
@@ -2288,7 +2585,7 @@ test assemble-20.1 {unbalanced stack} {
-returnCodes ok
}
-test assemble-20.2 {unbalanced stack} {*}{
+test assemble-30.2 {unbalanced stack} {*}{
-body {
list \
[catch {
@@ -2310,7 +2607,7 @@ test assemble-20.2 {unbalanced stack} {*}{
-returnCodes ok
}
-test assemble-21.1 {Inconsistent stack usage} {*}{
+test assemble-31.1 {Inconsistent stack usage} {*}{
-body {
proc x {y} {
assemble {
@@ -2333,7 +2630,7 @@ test assemble-21.1 {Inconsistent stack usage} {*}{
("assemble" body, line 10)*}
}
-test assemble-22.1 {Ulam's 3n+1 problem, TAL implementation} {
+test assemble-40.1 {Ulam's 3n+1 problem, TAL implementation} {
-body {
proc ulam {n} {
assemble {