From 1d6e389d18aa4c400d9dde126e35fe5eb88bf70e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 23 Nov 2008 21:40:54 -0600
Subject: [PATCH] Fixing walker, adding traceback tests

---
 basis/tools/walker/walker-tests.factor |  6 +++-
 basis/tools/walker/walker.factor       | 26 +++++++++++-----
 core/kernel/kernel-tests.factor        | 41 +++++++++++++++++++++++++-
 vm/quotations.c                        | 13 ++++----
 4 files changed, 71 insertions(+), 15 deletions(-)

diff --git a/basis/tools/walker/walker-tests.factor b/basis/tools/walker/walker-tests.factor
index e002af8f6d..f802676583 100644
--- a/basis/tools/walker/walker-tests.factor
+++ b/basis/tools/walker/walker-tests.factor
@@ -17,7 +17,11 @@ IN: tools.walker.tests
 ] unit-test
 
 [ { "Yo" 2 } ] [
-    [ 2 >r "Yo" r> ] test-walker
+    [ 2 [ "Yo" ] dip ] test-walker
+] unit-test
+
+[ { "Yo" 2 3 } ] [
+    [ 2 [ "Yo" ] dip 3 ] test-walker
 ] unit-test
 
 [ { 2 } ] [
diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor
index 1d26567952..9b2f5e4705 100644
--- a/basis/tools/walker/walker.factor
+++ b/basis/tools/walker/walker.factor
@@ -64,6 +64,12 @@ M: object add-breakpoint ;
 
 : (step-into-quot) ( quot -- ) add-breakpoint call ;
 
+: (step-into-dip) ( quot -- ) add-breakpoint dip ;
+
+: (step-into-2dip) ( quot -- ) add-breakpoint 2dip ;
+
+: (step-into-3dip) ( quot -- ) add-breakpoint 3dip ;
+
 : (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
 
 : (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
@@ -130,6 +136,9 @@ SYMBOL: +stopped+
 
 {
     { call [ (step-into-quot) ] }
+    { dip [ (step-into-dip) ] }
+    { 2dip [ (step-into-2dip) ] }
+    { 3dip [ (step-into-3dip) ] }
     { (throw) [ drop (step-into-quot) ] }
     { execute [ (step-into-execute) ] }
     { if [ (step-into-if) ] }
@@ -152,13 +161,16 @@ SYMBOL: +stopped+
 : step-into-msg ( continuation -- continuation' )
     [
         swap cut [
-            swap % unclip {
-                { [ dup \ break eq? ] [ , ] }
-                { [ dup quotation? ] [ add-breakpoint , \ break , ] }
-                { [ dup array? ] [ add-breakpoint , \ break , ] }
-                { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
-                [ , \ break , ]
-            } cond %
+            swap %
+            [ \ break , ] [
+                unclip {
+                    { [ dup \ break eq? ] [ , ] }
+                    { [ dup quotation? ] [ add-breakpoint , \ break , ] }
+                    { [ dup array? ] [ add-breakpoint , \ break , ] }
+                    { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
+                    [ , \ break , ]
+                } cond %
+            ] if-empty
         ] [ ] make
     ] change-frame ;
 
diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor
index 6619d331f1..320025b124 100644
--- a/core/kernel/kernel-tests.factor
+++ b/core/kernel/kernel-tests.factor
@@ -1,7 +1,7 @@
 USING: arrays byte-arrays kernel kernel.private math memory
 namespaces sequences tools.test math.private quotations
 continuations prettyprint io.streams.string debugger assocs
-sequences.private ;
+sequences.private accessors ;
 IN: kernel.tests
 
 [ 0 ] [ f size ] unit-test
@@ -124,3 +124,42 @@ IN: kernel.tests
 [ [ sq ] tri@ ] must-infer
 
 [ 4 ] [ 1 { [ 1 ] [ 2 ] } dispatch sq ] unit-test
+
+! Test traceback accuracy
+: last-frame ( -- pair )
+    error-continuation get call>> callstack>array 4 head* 2 tail* ;
+
+[
+    { [ 1 2 [ 3 throw ] call 4 ] 3 }
+] [
+    [ [ 1 2 [ 3 throw ] call 4 ] call ] ignore-errors
+    last-frame
+] unit-test
+
+[
+    { [ 1 2 [ 3 throw ] dip 4 ] 3 }
+] [
+    [ [ 1 2 [ 3 throw ] dip 4 ] call ] ignore-errors
+    last-frame
+] unit-test
+
+[
+    { [ 1 2 3 throw [ ] call 4 ] 3 }
+] [
+    [ [ 1 2 3 throw [ ] call 4 ] call ] ignore-errors
+    last-frame
+] unit-test
+
+[
+    { [ 1 2 3 throw [ ] dip 4 ] 3 }
+] [
+    [ [ 1 2 3 throw [ ] dip 4 ] call ] ignore-errors
+    last-frame
+] unit-test
+
+[
+    { [ 1 2 3 throw [ ] [ ] if 4 ] 3 }
+] [
+    [ [ 1 2 3 throw [ ] [ ] if 4 ] call ] ignore-errors
+    last-frame
+] unit-test
diff --git a/vm/quotations.c b/vm/quotations.c
index 179224f798..4a8845239b 100755
--- a/vm/quotations.c
+++ b/vm/quotations.c
@@ -348,8 +348,10 @@ worse than the duplication itself (eg, putting all state in some global
 struct.) */
 #define COUNT(name,scan) \
 	{ \
+		CELL size = array_capacity(code_to_emit(name)) * code_format; \
 		if(offset == 0) return scan - 1; \
-		offset -= array_capacity(code_to_emit(name)) * code_format; \
+		if(offset < size) return scan + 1; \
+		offset -= size; \
 	}
 
 F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
@@ -411,29 +413,28 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
 				if(stack_frame)
 					COUNT(userenv[JIT_EPILOG],i)
 
-				i += 2;
-
 				COUNT(userenv[JIT_IF_JUMP],i)
+				i += 2;
 
 				tail_call = true;
 				break;
 			}
 			else if(jit_fast_dip_p(untag_object(array),i))
 			{
-				i++;
 				COUNT(userenv[JIT_DIP],i)
+				i++;
 				break;
 			}
 			else if(jit_fast_2dip_p(untag_object(array),i))
 			{
-				i++;
 				COUNT(userenv[JIT_2DIP],i)
+				i++;
 				break;
 			}
 			else if(jit_fast_3dip_p(untag_object(array),i))
 			{
-				i++;
 				COUNT(userenv[JIT_3DIP],i)
+				i++;
 				break;
 			}
 		case ARRAY_TYPE: