[pforth] / fth / utils / trace.fth

\ @(#) trace.fth 98/01/08 1.1\r
\ TRACE ( <name> -- , trace pForth word )\r
\\r
\ Single step debugger.\r
\   TRACE  ( i*x <name> -- , setup trace for Forth word )\r
\   S      ( -- , step over )\r
\   SM     ( many -- , step over many times )\r
\   SD     ( -- , step down )\r
\   G      ( -- , go to end of word )\r
\   GD     ( n -- , go down N levels from current level, stop at end of this level )\r
\\r
\ This debugger works by emulating the inner interpreter of pForth.\r
\ It executes code and maintains a separate return stack for the\r
\ program under test.  Thus all primitives that operate on the return\r
\ stack, such as DO and R> must be trapped.  Local variables must\r
\ also be handled specially.  Several state variables are also\r
\ saved and restored to establish the context for the program being\r
\ tested.\r
\    \r
\ Copyright 1997 Phil Burk\r
\r
anew task-trace.fth\r
\r
: SPACE.TO.COLUMN  ( col -- )\r
	out @ - spaces\r
;\r
\r
: IS.PRIMITIVE? ( xt -- flag , true if kernel primitive )\r
	['] first_colon <\r
;\r
\r
0 value TRACE_IP         \ instruction pointer\r
0 value TRACE_LEVEL      \ level of descent for inner interpreter\r
0 value TRACE_LEVEL_MAX  \ maximum level of descent\r
\r
private{\r
\r
\ use fake return stack\r
128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes\r
create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot\r
variable TRACE-RSP\r
: TRACE.>R     ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ;  \ *(--rsp) = n\r
: TRACE.R>     ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ;  \ n = *rsp++\r
: TRACE.R@     ( -- n ) trace-rsp @ @ ; ; \ n = *rsp\r
: TRACE.RPICK  ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index]\r
: TRACE.0RP    ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ;\r
: TRACE.RDROP  ( --  ) cell trace-rsp +! ;\r
: TRACE.RCHECK ( -- , abort if return stack out of range )\r
	trace-rsp @ trace-return-stack u<\r
		abort" TRACE return stack OVERFLOW!"\r
	trace-rsp @ trace-return-stack trace_return_size + 12 + u>\r
		abort" TRACE return stack UNDERFLOW!"\r
;\r
\r
\ save and restore several state variables\r
10 cells constant TRACE_STATE_SIZE\r
create TRACE-STATE-1 TRACE_STATE_SIZE allot\r
create TRACE-STATE-2 TRACE_STATE_SIZE allot\r
\r
variable TRACE-STATE-PTR\r
: TRACE.SAVE++ ( addr -- , save next thing )\r
	@ trace-state-ptr @ !\r
	cell trace-state-ptr +!\r
;\r
\r
: TRACE.SAVE.STATE  ( -- )\r
	state trace.save++\r
	hld   trace.save++\r
	base  trace.save++\r
;\r
\r
: TRACE.SAVE.STATE1  ( -- , save normal state )\r
	trace-state-1 trace-state-ptr !\r
	trace.save.state\r
;\r
: TRACE.SAVE.STATE2  ( -- , save state of word being debugged )\r
	trace-state-2 trace-state-ptr !\r
	trace.save.state\r
;\r
\r
\r
: TRACE.RESTORE++ ( addr -- , restore next thing )\r
	trace-state-ptr @ @ swap !\r
	cell trace-state-ptr +!\r
;\r
\r
: TRACE.RESTORE.STATE  ( -- )\r
	state trace.restore++\r
	hld   trace.restore++\r
	base  trace.restore++\r
;\r
\r
: TRACE.RESTORE.STATE1  ( -- )\r
	trace-state-1 trace-state-ptr !\r
	trace.restore.state\r
;\r
: TRACE.RESTORE.STATE2  ( -- )\r
	trace-state-2 trace-state-ptr !\r
	trace.restore.state\r
;\r
\r
\ The implementation of these pForth primitives is specific to pForth.\r
\r
variable TRACE-LOCALS-PTR  \ point to top of local frame\r
\r
\ create a return stack frame for NUM local variables\r
: TRACE.(LOCAL.ENTRY)  ( x0 x1 ... xn n -- )  { num | lp -- }\r
	trace-locals-ptr @ trace.>r\r
	trace-rsp @ trace-locals-ptr !\r
	trace-rsp @  num cells - trace-rsp !  \ make room for locals\r
	trace-rsp @ -> lp\r
	num 0\r
	DO\r
		lp !\r
		cell +-> lp  \ move data into locals frame on return stack\r
	LOOP\r
;\r
	\r
: TRACE.(LOCAL.EXIT) ( -- )\r
	trace-locals-ptr @  trace-rsp !\r
	trace.r> trace-locals-ptr !\r
;\r
: TRACE.(LOCAL@) ( l# -- n , fetch from local frame )\r
	trace-locals-ptr @  swap cells - @\r
;\r
: TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ;\r
: TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ;\r
: TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ;\r
: TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ;\r
: TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ;\r
: TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ;\r
: TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ;\r
: TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ;\r
\r
: TRACE.(LOCAL!) ( n l# -- , store into local frame )\r
	trace-locals-ptr @  swap cells - !\r
;\r
: TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ;\r
: TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ;\r
: TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ;\r
: TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ;\r
: TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ;\r
: TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ;\r
: TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ;\r
: TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ;\r
\r
: TRACE.(LOCAL+!) ( n l# -- , store into local frame )\r
	trace-locals-ptr @  swap cells - +!\r
;\r
: TRACE.(?DO)  { limit start ip -- ip' }\r
	limit start =\r
	IF\r
		ip @ +-> ip \ BRANCH\r
	ELSE\r
		start trace.>r\r
		limit trace.>r\r
		cell +-> ip\r
	THEN\r
	ip\r
;\r
\r
: TRACE.(LOOP)  { ip | limit indx -- ip' }\r
	trace.r> -> limit\r
	trace.r> 1+ -> indx\r
	limit indx =\r
	IF\r
		cell +-> ip\r
	ELSE\r
		indx trace.>r\r
		limit trace.>r\r
		ip @ +-> ip\r
	THEN\r
	ip\r
;\r
\r
: TRACE.(+LOOP)  { delta ip | limit indx oldindx -- ip' }\r
	trace.r> -> limit\r
	trace.r> -> oldindx\r
	oldindx delta + -> indx\r
\ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */\r
\  if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||\r
\    ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )\r
	oldindx limit -    limit 1-    indx -  AND $ 80000000 AND\r
	   indx limit -    limit 1- oldindx -  AND $ 80000000 AND OR\r
	IF\r
		cell +-> ip\r
	ELSE\r
		indx trace.>r\r
		limit trace.>r\r
		ip @ +-> ip\r
	THEN\r
	ip\r
;\r
\r
: TRACE.CHECK.IP  {  ip -- }\r
	ip ['] first_colon u<\r
	ip here u> OR\r
	IF\r
		." TRACE - IP out of range = " ip .hex cr\r
		abort\r
	THEN\r
;\r
\r
: TRACE.SHOW.IP { ip -- , print name and offset }\r
	ip code> >name dup id.\r
	name> >code ip swap - ."  +" .\r
;\r
\r
: TRACE.SHOW.STACK { | mdepth -- }\r
	base @ >r\r
	." <" base @ decimal 1 .r ." :"\r
	depth 1 .r ." > "\r
	r> base !\r
	depth 5 min -> mdepth\r
	depth mdepth  -\r
	IF\r
		." ... "  \ if we don't show entire stack\r
	THEN\r
	mdepth 0\r
	?DO\r
		mdepth i 1+ - pick .  \ show numbers in current base\r
	LOOP\r
;\r
\r
: TRACE.SHOW.NEXT { ip -- }\r
	>newline\r
	ip trace.check.ip\r
\ show word name and offset\r
	." <<  "\r
	ip trace.show.ip\r
	30 space.to.column\r
\ show data stack\r
	trace.show.stack\r
	65 space.to.column ."  ||"\r
	trace_level 2* spaces\r
	ip code@\r
	cell +-> ip\r
\ show primitive about to be executed\r
	dup .xt space\r
\ trap any primitives that are followed by inline data\r
	CASE\r
		['] (LITERAL)  OF ip @  . ENDOF\r
		['] (ALITERAL) OF ip a@ . ENDOF\r
[ exists? (FLITERAL) [IF] ]\r
		['] (FLITERAL) OF ip f@ f. ENDOF\r
[ [THEN] ]\r
		['] BRANCH     OF ip @  . ENDOF\r
		['] 0BRANCH    OF ip @  . ENDOF\r
		['] (.")       OF ip count type .' "' ENDOF\r
		['] (C")       OF ip count type .' "' ENDOF\r
		['] (S")       OF ip count type .' "' ENDOF\r
	ENDCASE\r
	100 space.to.column ."  >> "\r
;\r
\r
: TRACE.DO.PRIMITIVE  { ip xt | oldhere --  ip' , perform code at ip }\r
	xt\r
	CASE\r
		0 OF -1 +-> trace_level  trace.r> -> ip ENDOF \ EXIT\r
		['] (CREATE)   OF ip cell- body_offset + ENDOF\r
		['] (LITERAL)  OF ip @ cell +-> ip ENDOF\r
		['] (ALITERAL) OF ip a@ cell +-> ip ENDOF\r
[ exists? (FLITERAL) [IF] ]\r
		['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF\r
[ [THEN] ]\r
		['] BRANCH     OF ip @ +-> ip ENDOF\r
		['] 0BRANCH    OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF\r
		['] >R         OF trace.>r ENDOF\r
		['] R>         OF trace.r> ENDOF\r
		['] R@         OF trace.r@ ENDOF\r
		['] RDROP      OF trace.rdrop ENDOF\r
		['] 2>R        OF trace.>r trace.>r ENDOF\r
		['] 2R>        OF trace.r> trace.r> ENDOF\r
		['] 2R@        OF trace.r@ 1 trace.rpick ENDOF\r
		['] i          OF 1 trace.rpick ENDOF\r
		['] j          OF 3 trace.rpick ENDOF\r
		['] (LEAVE)    OF trace.rdrop trace.rdrop  ip @ +-> ip ENDOF\r
		['] (LOOP)     OF ip trace.(loop) -> ip  ENDOF\r
		['] (+LOOP)    OF ip trace.(+loop) -> ip  ENDOF\r
		['] (DO)       OF trace.>r trace.>r ENDOF\r
		['] (?DO)      OF ip trace.(?do) -> ip ENDOF\r
		['] (.")       OF ip count type  ip count + aligned -> ip ENDOF\r
		['] (C")       OF ip  ip count + aligned -> ip ENDOF\r
		['] (S")       OF ip count  ip count + aligned -> ip ENDOF\r
		['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF\r
		['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF\r
		['] (LOCAL@)   OF trace.(local@)   ENDOF\r
		['] (1_LOCAL@) OF trace.(1_local@) ENDOF\r
		['] (2_LOCAL@) OF trace.(2_local@) ENDOF\r
		['] (3_LOCAL@) OF trace.(3_local@) ENDOF\r
		['] (4_LOCAL@) OF trace.(4_local@) ENDOF\r
		['] (5_LOCAL@) OF trace.(5_local@) ENDOF\r
		['] (6_LOCAL@) OF trace.(6_local@) ENDOF\r
		['] (7_LOCAL@) OF trace.(7_local@) ENDOF\r
		['] (8_LOCAL@) OF trace.(8_local@) ENDOF\r
		['] (LOCAL!)   OF trace.(local!)   ENDOF\r
		['] (1_LOCAL!) OF trace.(1_local!) ENDOF\r
		['] (2_LOCAL!) OF trace.(2_local!) ENDOF\r
		['] (3_LOCAL!) OF trace.(3_local!) ENDOF\r
		['] (4_LOCAL!) OF trace.(4_local!) ENDOF\r
		['] (5_LOCAL!) OF trace.(5_local!) ENDOF\r
		['] (6_LOCAL!) OF trace.(6_local!) ENDOF\r
		['] (7_LOCAL!) OF trace.(7_local!) ENDOF\r
		['] (8_LOCAL!) OF trace.(8_local!) ENDOF\r
		['] (LOCAL+!)  OF trace.(local+!)  ENDOF\r
		>r xt EXECUTE r>\r
	ENDCASE\r
	ip\r
;\r
\r
: TRACE.DO.NEXT  { ip | xt oldhere --  ip' , perform code at ip }\r
	ip trace.check.ip\r
\ set context for word under test\r
	trace.save.state1\r
	here -> oldhere\r
	trace.restore.state2\r
	oldhere 256 + dp !\r
\ get execution token\r
	ip code@ -> xt\r
	cell +-> ip\r
\ execute token\r
	xt is.primitive?\r
	IF  \ primitive\r
		ip xt trace.do.primitive -> ip\r
	ELSE \ secondary\r
		trace_level trace_level_max <\r
		IF\r
			ip trace.>r         \ threaded execution\r
			1 +-> trace_level\r
			xt codebase + -> ip\r
		ELSE\r
			\ treat it as a primitive\r
			ip xt trace.do.primitive -> ip\r
		THEN		\r
	THEN\r
\ restore original context\r
	trace.rcheck\r
	trace.save.state2\r
	trace.restore.state1\r
	oldhere dp !\r
	ip\r
;\r
\r
: TRACE.NEXT { ip | xt -- ip' }\r
	trace_level 0>\r
	IF\r
		ip trace.do.next -> ip\r
	THEN\r
	trace_level 0>\r
	IF\r
		ip trace.show.next\r
	ELSE\r
		." Finished." cr\r
	THEN\r
	ip\r
;\r
\r
}private\r
\r
: TRACE ( i*x <name> -- i*x , setup trace environment )\r
	' dup is.primitive?\r
	IF\r
		drop ." Sorry. You can't trace a primitive." cr\r
	ELSE\r
		1 -> trace_level\r
		trace_level -> trace_level_max\r
		trace.0rp\r
		>code -> trace_ip\r
		trace_ip trace.show.next\r
		trace-stack off\r
		trace.save.state2\r
	THEN\r
;\r
\r
: s ( -- , step over )\r
	trace_level -> trace_level_max\r
	trace_ip trace.next -> trace_ip\r
;\r
\r
: sd ( -- , step down )\r
	trace_level 1+ -> trace_level_max\r
	trace_ip trace.next -> trace_ip\r
;\r
\r
: sm ( many -- , step down )\r
	trace_level -> trace_level_max\r
	0\r
	?DO\r
		trace_ip trace.next -> trace_ip\r
	LOOP\r
;\r
\r
: gd { more_levels | stop_level -- }\r
	depth 1 <\r
	IF\r
		." GD requires a MORE_LEVELS parameter." cr\r
	ELSE\r
		trace_level more_levels + -> trace_level_max\r
		trace_level 1- -> stop_level\r
		BEGIN\r
			trace_ip trace.next -> trace_ip\r
			trace_level stop_level > not\r
		UNTIL\r
	THEN\r
;\r
\r
: g ( -- , execute until end of word )\r
	0 gd\r
;\r
\r
: TRACE.HELP ( -- )\r
	."   TRACE  ( i*x <name> -- , setup trace for Forth word )" cr\r
	."   S      ( -- , step over )" cr\r
	."   SM     ( many -- , step over many times )" cr\r
	."   SD     ( -- , step down )" cr\r
	."   G      ( -- , go to end of word )" cr\r
	."   GD     ( n -- , go down N levels from current level," cr\r
	."                   stop at end of this level )" cr\r
;\r
\r
privatize\r
\r
0 [IF]\r
variable var1\r
100 var1 !\r
: FOO  dup IF 1 + . THEN 77 var1 @ + . ;\r
: ZOO 29 foo 99 22 + . ;\r
: ROO 92 >r 1 r@ + . r> . ;\r
: MOO  c" hello" count type\r
	." This is a message." cr\r
	s" another message" type cr\r
;\r
: KOO 7 FOO ." DONE" ;\r
: TR.DO  4 0 DO i . LOOP ;\r
: TR.?DO  0 ?DO i . LOOP ;\r
: TR.LOC1 { aa bb } aa bb + . ;\r
: TR.LOC2 789 >r 4 5 tr.loc1 r> . ;\r
[THEN]\r
Commit	Line	Data
bb6b2dcd	1	\ @(#) trace.fth 98/01/08 1.1\r
	2	\ TRACE ( <name> -- , trace pForth word )\r
	3	\\r
	4	\ Single step debugger.\r
	5	\ TRACE ( i*x <name> -- , setup trace for Forth word )\r
	6	\ S ( -- , step over )\r
	7	\ SM ( many -- , step over many times )\r
	8	\ SD ( -- , step down )\r
	9	\ G ( -- , go to end of word )\r
	10	\ GD ( n -- , go down N levels from current level, stop at end of this level )\r
	11	\\r
	12	\ This debugger works by emulating the inner interpreter of pForth.\r
	13	\ It executes code and maintains a separate return stack for the\r
	14	\ program under test. Thus all primitives that operate on the return\r
	15	\ stack, such as DO and R> must be trapped. Local variables must\r
	16	\ also be handled specially. Several state variables are also\r
	17	\ saved and restored to establish the context for the program being\r
	18	\ tested.\r
	19	\ \r
	20	\ Copyright 1997 Phil Burk\r
	21	\r
	22	anew task-trace.fth\r
	23	\r
	24	: SPACE.TO.COLUMN ( col -- )\r
	25	out @ - spaces\r
	26	;\r
	27	\r
	28	: IS.PRIMITIVE? ( xt -- flag , true if kernel primitive )\r
	29	['] first_colon <\r
	30	;\r
	31	\r
	32	0 value TRACE_IP \ instruction pointer\r
	33	0 value TRACE_LEVEL \ level of descent for inner interpreter\r
	34	0 value TRACE_LEVEL_MAX \ maximum level of descent\r
	35	\r
	36	private{\r
	37	\r
	38	\ use fake return stack\r
	39	128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes\r
	40	create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot\r
	41	variable TRACE-RSP\r
	42	: TRACE.>R ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ; \ *(--rsp) = n\r
	43	: TRACE.R> ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ; \ n = *rsp++\r
	44	: TRACE.R@ ( -- n ) trace-rsp @ @ ; ; \ n = *rsp\r
	45	: TRACE.RPICK ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index]\r
	46	: TRACE.0RP ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ;\r
	47	: TRACE.RDROP ( -- ) cell trace-rsp +! ;\r
	48	: TRACE.RCHECK ( -- , abort if return stack out of range )\r
	49	trace-rsp @ trace-return-stack u<\r
	50	abort" TRACE return stack OVERFLOW!"\r
	51	trace-rsp @ trace-return-stack trace_return_size + 12 + u>\r
	52	abort" TRACE return stack UNDERFLOW!"\r
	53	;\r
	54	\r
	55	\ save and restore several state variables\r
	56	10 cells constant TRACE_STATE_SIZE\r
	57	create TRACE-STATE-1 TRACE_STATE_SIZE allot\r
	58	create TRACE-STATE-2 TRACE_STATE_SIZE allot\r
	59	\r
	60	variable TRACE-STATE-PTR\r
	61	: TRACE.SAVE++ ( addr -- , save next thing )\r
	62	@ trace-state-ptr @ !\r
	63	cell trace-state-ptr +!\r
	64	;\r
65	\r
66	: TRACE.SAVE.STATE ( -- )\r
67	state trace.save++\r
68	hld trace.save++\r
69	base trace.save++\r
70	;\r
71	\r
72	: TRACE.SAVE.STATE1 ( -- , save normal state )\r
73	trace-state-1 trace-state-ptr !\r
74	trace.save.state\r
75	;\r
76	: TRACE.SAVE.STATE2 ( -- , save state of word being debugged )\r
77	trace-state-2 trace-state-ptr !\r
78	trace.save.state\r
79	;\r
80	\r
81	\r
82	: TRACE.RESTORE++ ( addr -- , restore next thing )\r
83	trace-state-ptr @ @ swap !\r
84	cell trace-state-ptr +!\r
85	;\r
86	\r
87	: TRACE.RESTORE.STATE ( -- )\r
88	state trace.restore++\r
89	hld trace.restore++\r
90	base trace.restore++\r
91	;\r
92	\r
93	: TRACE.RESTORE.STATE1 ( -- )\r
94	trace-state-1 trace-state-ptr !\r
95	trace.restore.state\r
96	;\r
97	: TRACE.RESTORE.STATE2 ( -- )\r
98	trace-state-2 trace-state-ptr !\r
99	trace.restore.state\r
100	;\r
101	\r
102	\ The implementation of these pForth primitives is specific to pForth.\r
103	\r
104	variable TRACE-LOCALS-PTR \ point to top of local frame\r
105	\r
106	\ create a return stack frame for NUM local variables\r
107	: TRACE.(LOCAL.ENTRY) ( x0 x1 ... xn n -- ) { num \| lp -- }\r
108	trace-locals-ptr @ trace.>r\r
109	trace-rsp @ trace-locals-ptr !\r
110	trace-rsp @ num cells - trace-rsp ! \ make room for locals\r
111	trace-rsp @ -> lp\r
112	num 0\r
113	DO\r
114	lp !\r
115	cell +-> lp \ move data into locals frame on return stack\r
116	LOOP\r
117	;\r
118	\r
119	: TRACE.(LOCAL.EXIT) ( -- )\r
120	trace-locals-ptr @ trace-rsp !\r
121	trace.r> trace-locals-ptr !\r
122	;\r
123	: TRACE.(LOCAL@) ( l# -- n , fetch from local frame )\r
124	trace-locals-ptr @ swap cells - @\r
125	;\r
126	: TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ;\r
127	: TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ;\r
128	: TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ;\r
129	: TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ;\r
130	: TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ;\r
131	: TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ;\r
132	: TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ;\r
133	: TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ;\r
134	\r
135	: TRACE.(LOCAL!) ( n l# -- , store into local frame )\r
136	trace-locals-ptr @ swap cells - !\r
137	;\r
138	: TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ;\r
139	: TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ;\r
140	: TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ;\r
141	: TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ;\r
142	: TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ;\r
143	: TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ;\r
144	: TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ;\r
145	: TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ;\r
146	\r
147	: TRACE.(LOCAL+!) ( n l# -- , store into local frame )\r
148	trace-locals-ptr @ swap cells - +!\r
149	;\r
150	: TRACE.(?DO) { limit start ip -- ip' }\r
151	limit start =\r
152	IF\r
153	ip @ +-> ip \ BRANCH\r
154	ELSE\r
155	start trace.>r\r
156	limit trace.>r\r
157	cell +-> ip\r
158	THEN\r
159	ip\r
160	;\r
161	\r
162	: TRACE.(LOOP) { ip \| limit indx -- ip' }\r
163	trace.r> -> limit\r
164	trace.r> 1+ -> indx\r
165	limit indx =\r
166	IF\r
167	cell +-> ip\r
168	ELSE\r
169	indx trace.>r\r
170	limit trace.>r\r
171	ip @ +-> ip\r
172	THEN\r
173	ip\r
174	;\r
175	\r
176	: TRACE.(+LOOP) { delta ip \| limit indx oldindx -- ip' }\r
177	trace.r> -> limit\r
178	trace.r> -> oldindx\r
179	oldindx delta + -> indx\r
180	\ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */\r
181	\ if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) \|\|\r
182	\ ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )\r
183	oldindx limit - limit 1- indx - AND $ 80000000 AND\r
184	indx limit - limit 1- oldindx - AND $ 80000000 AND OR\r
185	IF\r
186	cell +-> ip\r
187	ELSE\r
188	indx trace.>r\r
189	limit trace.>r\r
190	ip @ +-> ip\r
191	THEN\r
192	ip\r
193	;\r
194	\r
195	: TRACE.CHECK.IP { ip -- }\r
196	ip ['] first_colon u<\r
197	ip here u> OR\r
198	IF\r
199	." TRACE - IP out of range = " ip .hex cr\r
200	abort\r
201	THEN\r
202	;\r
203	\r
204	: TRACE.SHOW.IP { ip -- , print name and offset }\r
205	ip code> >name dup id.\r
206	name> >code ip swap - ." +" .\r
207	;\r
208	\r
209	: TRACE.SHOW.STACK { \| mdepth -- }\r
210	base @ >r\r
211	." <" base @ decimal 1 .r ." :"\r
212	depth 1 .r ." > "\r
213	r> base !\r
214	depth 5 min -> mdepth\r
215	depth mdepth -\r
216	IF\r
217	." ... " \ if we don't show entire stack\r
218	THEN\r
219	mdepth 0\r
220	?DO\r
221	mdepth i 1+ - pick . \ show numbers in current base\r
222	LOOP\r
223	;\r
224	\r
225	: TRACE.SHOW.NEXT { ip -- }\r
226	>newline\r
227	ip trace.check.ip\r
228	\ show word name and offset\r
229	." << "\r
230	ip trace.show.ip\r
231	30 space.to.column\r
232	\ show data stack\r
233	trace.show.stack\r
234	65 space.to.column ." \|\|"\r
235	trace_level 2* spaces\r
236	ip code@\r
237	cell +-> ip\r
238	\ show primitive about to be executed\r
239	dup .xt space\r
240	\ trap any primitives that are followed by inline data\r
241	CASE\r
242	['] (LITERAL) OF ip @ . ENDOF\r
243	['] (ALITERAL) OF ip a@ . ENDOF\r
244	[ exists? (FLITERAL) [IF] ]\r
245	['] (FLITERAL) OF ip f@ f. ENDOF\r
246	[ [THEN] ]\r
247	['] BRANCH OF ip @ . ENDOF\r
248	['] 0BRANCH OF ip @ . ENDOF\r
249	['] (.") OF ip count type .' "' ENDOF\r
250	['] (C") OF ip count type .' "' ENDOF\r
251	['] (S") OF ip count type .' "' ENDOF\r
252	ENDCASE\r
253	100 space.to.column ." >> "\r
254	;\r
255	\r
256	: TRACE.DO.PRIMITIVE { ip xt \| oldhere -- ip' , perform code at ip }\r
257	xt\r
258	CASE\r
259	0 OF -1 +-> trace_level trace.r> -> ip ENDOF \ EXIT\r
260	['] (CREATE) OF ip cell- body_offset + ENDOF\r
261	['] (LITERAL) OF ip @ cell +-> ip ENDOF\r
262	['] (ALITERAL) OF ip a@ cell +-> ip ENDOF\r
263	[ exists? (FLITERAL) [IF] ]\r
264	['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF\r
265	[ [THEN] ]\r
266	['] BRANCH OF ip @ +-> ip ENDOF\r
267	['] 0BRANCH OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF\r
268	['] >R OF trace.>r ENDOF\r
269	['] R> OF trace.r> ENDOF\r
270	['] R@ OF trace.r@ ENDOF\r
271	['] RDROP OF trace.rdrop ENDOF\r
272	['] 2>R OF trace.>r trace.>r ENDOF\r
273	['] 2R> OF trace.r> trace.r> ENDOF\r
274	['] 2R@ OF trace.r@ 1 trace.rpick ENDOF\r
275	['] i OF 1 trace.rpick ENDOF\r
276	['] j OF 3 trace.rpick ENDOF\r
277	['] (LEAVE) OF trace.rdrop trace.rdrop ip @ +-> ip ENDOF\r
278	['] (LOOP) OF ip trace.(loop) -> ip ENDOF\r
279	['] (+LOOP) OF ip trace.(+loop) -> ip ENDOF\r
280	['] (DO) OF trace.>r trace.>r ENDOF\r
281	['] (?DO) OF ip trace.(?do) -> ip ENDOF\r
282	['] (.") OF ip count type ip count + aligned -> ip ENDOF\r
283	['] (C") OF ip ip count + aligned -> ip ENDOF\r
284	['] (S") OF ip count ip count + aligned -> ip ENDOF\r
285	['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF\r
286	['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF\r
287	['] (LOCAL@) OF trace.(local@) ENDOF\r
288	['] (1_LOCAL@) OF trace.(1_local@) ENDOF\r
289	['] (2_LOCAL@) OF trace.(2_local@) ENDOF\r
290	['] (3_LOCAL@) OF trace.(3_local@) ENDOF\r
291	['] (4_LOCAL@) OF trace.(4_local@) ENDOF\r
292	['] (5_LOCAL@) OF trace.(5_local@) ENDOF\r
293	['] (6_LOCAL@) OF trace.(6_local@) ENDOF\r
294	['] (7_LOCAL@) OF trace.(7_local@) ENDOF\r
295	['] (8_LOCAL@) OF trace.(8_local@) ENDOF\r
296	['] (LOCAL!) OF trace.(local!) ENDOF\r
297	['] (1_LOCAL!) OF trace.(1_local!) ENDOF\r
298	['] (2_LOCAL!) OF trace.(2_local!) ENDOF\r
299	['] (3_LOCAL!) OF trace.(3_local!) ENDOF\r
300	['] (4_LOCAL!) OF trace.(4_local!) ENDOF\r
301	['] (5_LOCAL!) OF trace.(5_local!) ENDOF\r
302	['] (6_LOCAL!) OF trace.(6_local!) ENDOF\r
303	['] (7_LOCAL!) OF trace.(7_local!) ENDOF\r
304	['] (8_LOCAL!) OF trace.(8_local!) ENDOF\r
305	['] (LOCAL+!) OF trace.(local+!) ENDOF\r
306	>r xt EXECUTE r>\r
307	ENDCASE\r
308	ip\r
309	;\r
310	\r
311	: TRACE.DO.NEXT { ip \| xt oldhere -- ip' , perform code at ip }\r
312	ip trace.check.ip\r
313	\ set context for word under test\r
314	trace.save.state1\r
315	here -> oldhere\r
316	trace.restore.state2\r
317	oldhere 256 + dp !\r
318	\ get execution token\r
319	ip code@ -> xt\r
320	cell +-> ip\r
321	\ execute token\r
322	xt is.primitive?\r
323	IF \ primitive\r
324	ip xt trace.do.primitive -> ip\r
325	ELSE \ secondary\r
326	trace_level trace_level_max <\r
327	IF\r
328	ip trace.>r \ threaded execution\r
329	1 +-> trace_level\r
330	xt codebase + -> ip\r
331	ELSE\r
332	\ treat it as a primitive\r
333	ip xt trace.do.primitive -> ip\r
334	THEN \r
335	THEN\r
336	\ restore original context\r
337	trace.rcheck\r
338	trace.save.state2\r
339	trace.restore.state1\r
340	oldhere dp !\r
341	ip\r
342	;\r
343	\r
344	: TRACE.NEXT { ip \| xt -- ip' }\r
345	trace_level 0>\r
346	IF\r
347	ip trace.do.next -> ip\r
348	THEN\r
349	trace_level 0>\r
350	IF\r
351	ip trace.show.next\r
352	ELSE\r
353	." Finished." cr\r
354	THEN\r
355	ip\r
356	;\r
357	\r
358	}private\r
359	\r
360	: TRACE ( ix <name> -- ix , setup trace environment )\r
361	' dup is.primitive?\r
362	IF\r
363	drop ." Sorry. You can't trace a primitive." cr\r
364	ELSE\r
365	1 -> trace_level\r
366	trace_level -> trace_level_max\r
367	trace.0rp\r
368	>code -> trace_ip\r
369	trace_ip trace.show.next\r
370	trace-stack off\r
371	trace.save.state2\r
372	THEN\r
373	;\r
374	\r
375	: s ( -- , step over )\r
376	trace_level -> trace_level_max\r
377	trace_ip trace.next -> trace_ip\r
378	;\r
379	\r
380	: sd ( -- , step down )\r
381	trace_level 1+ -> trace_level_max\r
382	trace_ip trace.next -> trace_ip\r
383	;\r
384	\r
385	: sm ( many -- , step down )\r
386	trace_level -> trace_level_max\r
387	0\r
388	?DO\r
389	trace_ip trace.next -> trace_ip\r
390	LOOP\r
391	;\r
392	\r
393	: gd { more_levels \| stop_level -- }\r
394	depth 1 <\r
395	IF\r
396	." GD requires a MORE_LEVELS parameter." cr\r
397	ELSE\r
398	trace_level more_levels + -> trace_level_max\r
399	trace_level 1- -> stop_level\r
400	BEGIN\r
401	trace_ip trace.next -> trace_ip\r
402	trace_level stop_level > not\r
403	UNTIL\r
404	THEN\r
405	;\r
406	\r
407	: g ( -- , execute until end of word )\r
408	0 gd\r
409	;\r
410	\r
411	: TRACE.HELP ( -- )\r
412	." TRACE ( i*x <name> -- , setup trace for Forth word )" cr\r
413	." S ( -- , step over )" cr\r
414	." SM ( many -- , step over many times )" cr\r
415	." SD ( -- , step down )" cr\r
416	." G ( -- , go to end of word )" cr\r
417	." GD ( n -- , go down N levels from current level," cr\r
418	." stop at end of this level )" cr\r
419	;\r
420	\r
421	privatize\r
422	\r
423	0 [IF]\r
424	variable var1\r
425	100 var1 !\r
426	: FOO dup IF 1 + . THEN 77 var1 @ + . ;\r
427	: ZOO 29 foo 99 22 + . ;\r
428	: ROO 92 >r 1 r@ + . r> . ;\r
429	: MOO c" hello" count type\r
430	." This is a message." cr\r
431	s" another message" type cr\r
432	;\r
433	: KOO 7 FOO ." DONE" ;\r
434	: TR.DO 4 0 DO i . LOOP ;\r
435	: TR.?DO 0 ?DO i . LOOP ;\r
436	: TR.LOC1 { aa bb } aa bb + . ;\r
437	: TR.LOC2 789 >r 4 5 tr.loc1 r> . ;\r
438	[THEN]\r