summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--generic/tclAssembly.c10
-rw-r--r--tests/assemble.test109
2 files changed, 113 insertions, 6 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 40e79f5..689e9f9 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -39,6 +39,15 @@ static void AddInstructionToErrorInfo(Tcl_Interp* interp, Tcl_Obj* bcList,
int index);
static BasicBlock * AllocBB(AssembleEnv*);
static int AssembleOneLine(AssembleEnv* envPtr);
+static void BBAdjustStackDepth(BasicBlock* bbPtr, int consumed, int produced);
+static void BBUpdateStackReqs(BasicBlock* bbPtr, int tblind, int count);
+static void BBEmitInstInt1(AssembleEnv* assemEnvPtr, int tblind,
+ unsigned char opnd, int count);
+static void BBEmitInstInt4(AssembleEnv* assemEnvPtr, int tblind, int opnd,
+ int count);
+static void BBEmitInst1or4(AssembleEnv* assemEnvPtr, int tblind, int param,
+ int count);
+static void BBEmitOpcode(AssembleEnv* assemEnvPtr, int tblind, int count);
static int CheckNamespaceQualifiers(Tcl_Interp*, const char*, int);
static int CheckOneByte(Tcl_Interp*, int);
static int CheckSignedOneByte(Tcl_Interp*, int);
@@ -1779,6 +1788,7 @@ AllocBB(AssembleEnv* assemEnvPtr)
bb->visited = 0;
bb->predecessor = NULL;
+ bb->may_fall_thru = 0;
bb->jumpTargetLabelHashEntry = NULL;
bb->successor1 = NULL;
diff --git a/tests/assemble.test b/tests/assemble.test
index a2ce531..d64f004 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -6,19 +6,114 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
}
set assemble tcl::unsupported::assemble
-test assemble-1.1 {wrong # args} {
- -body { $assemble 1 2 }
- -result {wrong # args: should be "tcl::unsupported::assemble bytecodeList"}
+test assemble-1.1 {wrong # args, direct eval} {
+ -body {
+ eval [list ::tcl::unsupported::assemble]
+ }
+ -returnCodes error
+ -result {wrong # args*}
+ -match glob
+}
+
+test assemble-1.2 {wrong # args, direct eval} {
+ -body {
+ eval [list ::tcl::unsupported::assemble too many]
+ }
-returnCodes error
+ -result {wrong # args*}
+ -match glob
+}
+
+test assemble-1.3 {error reporting, direct eval} {
+ -body {
+ list [catch {
+ eval [list ::tcl::unsupported::assemble {
+ # bad opcode
+ rubbish
+ }]
+ } result] $result $errorInfo
+ }
+ -match glob
+ -result {1 {bad instruction "rubbish":*} {bad instruction "rubbish":*
+ while executing
+"rubbish"
+ ("::tcl::unsupported::assemble" body, line 3)*}}
+ -cleanup {unset result}
+}
+
+test assemble-1.4 {simple direct eval} {
+ -body {
+ eval [list ::tcl::unsupported::assemble {push {this is a test}}]
+ }
+ -result {this is a test}
+}
+
+test assemble-2.1 {bytecode reuse, direct eval} {
+ -body {
+ set x {push "this is a test"}
+ list [eval [list ::tcl::unsupported::assemble $x]] \
+ [eval [list ::tcl::unsupported::assemble $x]]
+ }
+ -result {{this is a test} {this is a test}}
+}
+
+test assemble-2.2 {bytecode discard, direct eval} {
+ -body {
+ set x {load value}
+ proc p1 {x} {
+ set value value1
+ tcl::unsupported::assemble $x
+ }
+ proc p2 {x} {
+ set a b
+ set value value2
+ tcl::unsupported::assemble $x
+ }
+ list [p1 $x] [p2 $x]
+ }
+ -result {value1 value2}
+ -cleanup {
+ unset x
+ rename p1 {}
+ rename p2 {}
+ }
+}
+
+test assemble-2.3 {null script, direct eval} {
+ -body {
+ set x {}
+ tcl::unsupported::assemble $x
+ }
+ -result {}
+ -cleanup {unset x}
}
-test assemble-1.2 {wrong arg formatting} {
- -body { $assemble 1 }
+test assemble-3.1 {wrong # args, compiled path} {
+ -body {
+ proc x {} {
+ tcl::unsupported::assemble
+ }
+ x
+ }
+ -returnCodes error
-match glob
+ -result {wrong # args:*}
+}
+
+test assemble-3.2 {wrong # args, compiled path} {
+ -body {
+ proc x {} {
+ tcl::unsupported::assemble too many
+ }
+ x
+ }
-returnCodes error
- -result {bad instruction "1"*}
+ -match glob
+ -result {wrong # args:*}
}
+if 0 {
+
test assemble-1.3 {empty body} {
-body { $assemble "" }
-result {}
@@ -737,6 +832,8 @@ test assemble-30.1 {Ulam's 3n+1 problem, TAL implementation} {
-result {1 2 16 4 16 16 52 8 52 16 52 16 40 52 160 16 52 52 88 20 64 52 160 24 88 40 9232 52 88}
}
+}
+
::tcltest::cleanupTests
return