Deleted Added
sdiff udiff text old ( 76116 ) new ( 94290 )
full compact
tools.c (76116) tools.c (94290)
1/*******************************************************************
2** t o o l s . c
3** Forth Inspired Command Language - programming tools
4** Author: John Sadler (john_sadler@alum.mit.edu)
5** Created: 20 June 2000
1/*******************************************************************
2** t o o l s . c
3** Forth Inspired Command Language - programming tools
4** Author: John Sadler (john_sadler@alum.mit.edu)
5** Created: 20 June 2000
6** $Id: tools.c,v 1.4 2001-04-26 21:41:24-07 jsadler Exp jsadler $
6** $Id: tools.c,v 1.11 2001/12/05 07:21:34 jsadler Exp $
7*******************************************************************/
8/*
7*******************************************************************/
8/*
9** NOTES:
10** SEE needs information about the addresses of functions that
11** are the CFAs of colon definitions, constants, variables, DOES>
12** words, and so on. It gets this information from a table and supporting
13** functions in words.c.
14** colonParen doDoes createParen variableParen userParen constantParen
15**
16** Step and break debugger for Ficl
17** debug ( xt -- ) Start debugging an xt
18** Set a breakpoint
19** Specify breakpoint default action
20*/
21/*
22** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
23** All rights reserved.
24**
25** Get the latest Ficl release at http://ficl.sourceforge.net
26**
9** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
10** All rights reserved.
11**
12** Get the latest Ficl release at http://ficl.sourceforge.net
13**
14** I am interested in hearing from anyone who uses ficl. If you have
15** a problem, a success story, a defect, an enhancement request, or
16** if you would like to contribute to the ficl release, please
17** contact me by email at the address above.
18**
27** L I C E N S E and D I S C L A I M E R
28**
29** Redistribution and use in source and binary forms, with or without
30** modification, are permitted provided that the following conditions
31** are met:
32** 1. Redistributions of source code must retain the above copyright
33** notice, this list of conditions and the following disclaimer.
34** 2. Redistributions in binary form must reproduce the above copyright

--- 6 unchanged lines hidden (view full) ---

41** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
42** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
43** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
44** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
45** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
46** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
47** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
48** SUCH DAMAGE.
19** L I C E N S E and D I S C L A I M E R
20**
21** Redistribution and use in source and binary forms, with or without
22** modification, are permitted provided that the following conditions
23** are met:
24** 1. Redistributions of source code must retain the above copyright
25** notice, this list of conditions and the following disclaimer.
26** 2. Redistributions in binary form must reproduce the above copyright

--- 6 unchanged lines hidden (view full) ---

33** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
34** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
35** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
36** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
37** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
38** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
39** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
40** SUCH DAMAGE.
41*/
42
43/*
44** NOTES:
45** SEE needs information about the addresses of functions that
46** are the CFAs of colon definitions, constants, variables, DOES>
47** words, and so on. It gets this information from a table and supporting
48** functions in words.c.
49** colonParen doDoes createParen variableParen userParen constantParen
49**
50**
50** I am interested in hearing from anyone who uses ficl. If you have
51** a problem, a success story, a defect, an enhancement request, or
52** if you would like to contribute to the ficl release, please send
53** contact me by email at the address above.
54**
55** $Id: tools.c,v 1.4 2001-04-26 21:41:24-07 jsadler Exp jsadler $
51** Step and break debugger for Ficl
52** debug ( xt -- ) Start debugging an xt
53** Set a breakpoint
54** Specify breakpoint default action
56*/
57
55*/
56
58/* $FreeBSD: head/sys/boot/ficl/tools.c 76116 2001-04-29 02:36:36Z dcs $ */
57/* $FreeBSD: head/sys/boot/ficl/tools.c 94290 2002-04-09 17:45:28Z dcs $ */
59
60#ifdef TESTMAIN
61#include <stdlib.h>
62#include <stdio.h> /* sprintf */
63#include <ctype.h>
64#else
65#include <stand.h>
66#endif
67#include <string.h>
68#include "ficl.h"
69
70
71#if 0
72/*
73** nBREAKPOINTS sizes the breakpoint array. One breakpoint (bp 0) is reserved
74** for the STEP command. The rest are user programmable.
75*/
76#define nBREAKPOINTS 32
58
59#ifdef TESTMAIN
60#include <stdlib.h>
61#include <stdio.h> /* sprintf */
62#include <ctype.h>
63#else
64#include <stand.h>
65#endif
66#include <string.h>
67#include "ficl.h"
68
69
70#if 0
71/*
72** nBREAKPOINTS sizes the breakpoint array. One breakpoint (bp 0) is reserved
73** for the STEP command. The rest are user programmable.
74*/
75#define nBREAKPOINTS 32
76
77#endif
78
77#endif
78
79/*
80** BREAKPOINT record.
81** origXT - if NULL, this breakpoint is unused. Otherwise it stores the xt
82** that the breakpoint overwrote. This is restored to the dictionary when the
83** BP executes or gets cleared
84** address - the location of the breakpoint (address of the instruction that
85** has been replaced with the breakpoint trap
86** origXT - The original contents of the location with the breakpoint
87** Note: address is NULL when this breakpoint is empty
88*/
89typedef struct breakpoint
90{
91 void *address;
92 FICL_WORD *origXT;
93} BREAKPOINT;
94
79
95static BREAKPOINT bpStep = {NULL, NULL};
96
97/*
98** vmSetBreak - set a breakpoint at the current value of IP by
80/**************************************************************************
81 v m S e t B r e a k
82** Set a breakpoint at the current value of IP by
99** storing that address in a BREAKPOINT record
83** storing that address in a BREAKPOINT record
100*/
101static void vmSetBreak(FICL_VM *pVM, BREAKPOINT *pBP)
84**************************************************************************/
85static void vmSetBreak(FICL_VM *pVM, FICL_BREAKPOINT *pBP)
102{
86{
103 FICL_WORD *pStep = ficlLookup("step-break");
87 FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break");
104 assert(pStep);
88 assert(pStep);
89
105 pBP->address = pVM->ip;
106 pBP->origXT = *pVM->ip;
107 *pVM->ip = pStep;
108}
109
110
90 pBP->address = pVM->ip;
91 pBP->origXT = *pVM->ip;
92 *pVM->ip = pStep;
93}
94
95
111/*
112** isAFiclWord
96/**************************************************************************
97** d e b u g P r o m p t
98**************************************************************************/
99static void debugPrompt(FICL_VM *pVM)
100{
101 vmTextOut(pVM, "dbg> ", 0);
102}
103
104
105/**************************************************************************
106** i s A F i c l W o r d
113** Vet a candidate pointer carefully to make sure
114** it's not some chunk o' inline data...
115** It has to have a name, and it has to look
116** like it's in the dictionary address range.
117** NOTE: this excludes :noname words!
107** Vet a candidate pointer carefully to make sure
108** it's not some chunk o' inline data...
109** It has to have a name, and it has to look
110** like it's in the dictionary address range.
111** NOTE: this excludes :noname words!
118*/
119int isAFiclWord(FICL_WORD *pFW)
112**************************************************************************/
113int isAFiclWord(FICL_DICT *pd, FICL_WORD *pFW)
120{
114{
121 FICL_DICT *pd = ficlGetDict();
122
123 if (!dictIncludes(pd, pFW))
124 return 0;
125
126 if (!dictIncludes(pd, pFW->name))
127 return 0;
128
115
116 if (!dictIncludes(pd, pFW))
117 return 0;
118
119 if (!dictIncludes(pd, pFW->name))
120 return 0;
121
129 return ((pFW->nName > 0) && (pFW->name[pFW->nName] == '\0'));
122 if ((pFW->link != NULL) && !dictIncludes(pd, pFW->link))
123 return 0;
124
125 if ((pFW->nName <= 0) || (pFW->name[pFW->nName] != '\0'))
126 return 0;
127
128 if (strlen(pFW->name) != pFW->nName)
129 return 0;
130
131 return 1;
130}
131
132
132}
133
134
135#if 0
133static int isPrimitive(FICL_WORD *pFW)
134{
135 WORDKIND wk = ficlWordClassify(pFW);
136 return ((wk != COLON) && (wk != DOES));
137}
136static int isPrimitive(FICL_WORD *pFW)
137{
138 WORDKIND wk = ficlWordClassify(pFW);
139 return ((wk != COLON) && (wk != DOES));
140}
141#endif
138
139
140/**************************************************************************
142
143
144/**************************************************************************
145 f i n d E n c l o s i n g W o r d
146** Given a pointer to something, check to make sure it's an address in the
147** dictionary. If so, search backwards until we find something that looks
148** like a dictionary header. If successful, return the address of the
149** FICL_WORD found. Otherwise return NULL.
150** nSEARCH_CELLS sets the maximum neighborhood this func will search before giving up
151**************************************************************************/
152#define nSEARCH_CELLS 100
153
154static FICL_WORD *findEnclosingWord(FICL_VM *pVM, CELL *cp)
155{
156 FICL_WORD *pFW;
157 FICL_DICT *pd = vmGetDict(pVM);
158 int i;
159
160 if (!dictIncludes(pd, (void *)cp))
161 return NULL;
162
163 for (i = nSEARCH_CELLS; i > 0; --i, --cp)
164 {
165 pFW = (FICL_WORD *)(cp + 1 - (sizeof (FICL_WORD) / sizeof (CELL)));
166 if (isAFiclWord(pd, pFW))
167 return pFW;
168 }
169
170 return NULL;
171}
172
173
174/**************************************************************************
141 s e e
142** TOOLS ( "<spaces>name" -- )
143** Display a human-readable representation of the named word's definition.
144** The source of the representation (object-code decompilation, source
145** block, etc.) and the particular form of the display is implementation
146** defined.
175 s e e
176** TOOLS ( "<spaces>name" -- )
177** Display a human-readable representation of the named word's definition.
178** The source of the representation (object-code decompilation, source
179** block, etc.) and the particular form of the display is implementation
180** defined.
147** NOTE: these funcs come late in the file because they reference all
148** of the word-builder funcs without declaring them again. Call me lazy.
149**************************************************************************/
150/*
151** seeColon (for proctologists only)
152** Walks a colon definition, decompiling
153** on the fly. Knows about primitive control structures.
154*/
155static void seeColon(FICL_VM *pVM, CELL *pc)
156{
181**************************************************************************/
182/*
183** seeColon (for proctologists only)
184** Walks a colon definition, decompiling
185** on the fly. Knows about primitive control structures.
186*/
187static void seeColon(FICL_VM *pVM, CELL *pc)
188{
157 static FICL_WORD *pSemiParen = NULL;
158
159 if (!pSemiParen)
160 pSemiParen = ficlLookup("(;)");
189 char *cp;
190 CELL *param0 = pc;
191 FICL_DICT *pd = vmGetDict(pVM);
192 FICL_WORD *pSemiParen = ficlLookup(pVM->pSys, "(;)");
161 assert(pSemiParen);
162
163 for (; pc->p != pSemiParen; pc++)
164 {
165 FICL_WORD *pFW = (FICL_WORD *)(pc->p);
166
193 assert(pSemiParen);
194
195 for (; pc->p != pSemiParen; pc++)
196 {
197 FICL_WORD *pFW = (FICL_WORD *)(pc->p);
198
167 if (isAFiclWord(pFW))
199 cp = pVM->pad;
200 if ((void *)pc == (void *)pVM->ip)
201 *cp++ = '>';
202 else
203 *cp++ = ' ';
204 cp += sprintf(cp, "%3d ", pc-param0);
205
206 if (isAFiclWord(pd, pFW))
168 {
169 WORDKIND kind = ficlWordClassify(pFW);
170 CELL c;
171
172 switch (kind)
173 {
174 case LITERAL:
175 c = *++pc;
207 {
208 WORDKIND kind = ficlWordClassify(pFW);
209 CELL c;
210
211 switch (kind)
212 {
213 case LITERAL:
214 c = *++pc;
176 if (isAFiclWord(c.p))
215 if (isAFiclWord(pd, c.p))
177 {
178 FICL_WORD *pLit = (FICL_WORD *)c.p;
216 {
217 FICL_WORD *pLit = (FICL_WORD *)c.p;
179 sprintf(pVM->pad, " literal %.*s (%#lx)",
218 sprintf(cp, "%.*s ( %#lx literal )",
180 pLit->nName, pLit->name, c.u);
181 }
182 else
219 pLit->nName, pLit->name, c.u);
220 }
221 else
183 sprintf(pVM->pad, " literal %ld (%#lx)", c.i, c.u);
222 sprintf(cp, "literal %ld (%#lx)", c.i, c.u);
184 break;
185 case STRINGLIT:
186 {
187 FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
188 pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
223 break;
224 case STRINGLIT:
225 {
226 FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
227 pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
189 sprintf(pVM->pad, " s\" %.*s\"", sp->count, sp->text);
228 sprintf(cp, "s\" %.*s\"", sp->count, sp->text);
190 }
191 break;
229 }
230 break;
231 case CSTRINGLIT:
232 {
233 FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
234 pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
235 sprintf(cp, "c\" %.*s\"", sp->count, sp->text);
236 }
237 break;
192 case IF:
193 c = *++pc;
194 if (c.i > 0)
238 case IF:
239 c = *++pc;
240 if (c.i > 0)
195 sprintf(pVM->pad, " if / while (branch rel %ld)", c.i);
241 sprintf(cp, "if / while (branch %d)", pc+c.i-param0);
196 else
242 else
197 sprintf(pVM->pad, " until (branch rel %ld)", c.i);
198 break;
243 sprintf(cp, "until (branch %d)", pc+c.i-param0);
244 break;
199 case BRANCH:
200 c = *++pc;
201 if (c.i > 0)
245 case BRANCH:
246 c = *++pc;
247 if (c.i > 0)
202 sprintf(pVM->pad, " else (branch rel %ld)", c.i);
248 sprintf(cp, "else (branch %d)", pc+c.i-param0);
203 else
249 else
204 sprintf(pVM->pad, " repeat (branch rel %ld)", c.i);
250 sprintf(cp, "repeat (branch %d)", pc+c.i-param0);
205 break;
206
207 case QDO:
208 c = *++pc;
251 break;
252
253 case QDO:
254 c = *++pc;
209 sprintf(pVM->pad, " ?do (leave abs %#lx)", c.u);
255 sprintf(cp, "?do (leave %d)", (CELL *)c.p-param0);
210 break;
211 case DO:
212 c = *++pc;
256 break;
257 case DO:
258 c = *++pc;
213 sprintf(pVM->pad, " do (leave abs %#lx)", c.u);
259 sprintf(cp, "do (leave %d)", (CELL *)c.p-param0);
214 break;
215 case LOOP:
216 c = *++pc;
260 break;
261 case LOOP:
262 c = *++pc;
217 sprintf(pVM->pad, " loop (branch rel %#ld)", c.i);
263 sprintf(cp, "loop (branch %d)", pc+c.i-param0);
218 break;
219 case PLOOP:
220 c = *++pc;
264 break;
265 case PLOOP:
266 c = *++pc;
221 sprintf(pVM->pad, " +loop (branch rel %#ld)", c.i);
267 sprintf(cp, "+loop (branch %d)", pc+c.i-param0);
222 break;
223 default:
268 break;
269 default:
224 sprintf(pVM->pad, " %.*s", pFW->nName, pFW->name);
270 sprintf(cp, "%.*s", pFW->nName, pFW->name);
225 break;
226 }
227
271 break;
272 }
273
228 vmTextOut(pVM, pVM->pad, 1);
229 }
230 else /* probably not a word - punt and print value */
231 {
274 }
275 else /* probably not a word - punt and print value */
276 {
232 sprintf(pVM->pad, " %ld (%#lx)", pc->i, pc->u);
233 vmTextOut(pVM, pVM->pad, 1);
277 sprintf(cp, "%ld ( %#lx )", pc->i, pc->u);
234 }
278 }
279
280 vmTextOut(pVM, pVM->pad, 1);
235 }
236
237 vmTextOut(pVM, ";", 1);
238}
239
240/*
241** Here's the outer part of the decompiler. It's
242** just a big nested conditional that checks the

--- 27 unchanged lines hidden (view full) ---

270 vmTextOut(pVM, "create", 1);
271 break;
272
273 case VARIABLE:
274 sprintf(pVM->pad, "variable = %ld (%#lx)", pFW->param->i, pFW->param->u);
275 vmTextOut(pVM, pVM->pad, 1);
276 break;
277
281 }
282
283 vmTextOut(pVM, ";", 1);
284}
285
286/*
287** Here's the outer part of the decompiler. It's
288** just a big nested conditional that checks the

--- 27 unchanged lines hidden (view full) ---

316 vmTextOut(pVM, "create", 1);
317 break;
318
319 case VARIABLE:
320 sprintf(pVM->pad, "variable = %ld (%#lx)", pFW->param->i, pFW->param->u);
321 vmTextOut(pVM, pVM->pad, 1);
322 break;
323
324#if FICL_WANT_USER
278 case USER:
279 sprintf(pVM->pad, "user variable %ld (%#lx)", pFW->param->i, pFW->param->u);
280 vmTextOut(pVM, pVM->pad, 1);
281 break;
325 case USER:
326 sprintf(pVM->pad, "user variable %ld (%#lx)", pFW->param->i, pFW->param->u);
327 vmTextOut(pVM, pVM->pad, 1);
328 break;
329#endif
282
283 case CONSTANT:
284 sprintf(pVM->pad, "constant = %ld (%#lx)", pFW->param->i, pFW->param->u);
285 vmTextOut(pVM, pVM->pad, 1);
286
287 default:
330
331 case CONSTANT:
332 sprintf(pVM->pad, "constant = %ld (%#lx)", pFW->param->i, pFW->param->u);
333 vmTextOut(pVM, pVM->pad, 1);
334
335 default:
288 vmTextOut(pVM, "primitive", 1);
336 sprintf(pVM->pad, "%.*s is a primitive", pFW->nName, pFW->name);
337 vmTextOut(pVM, pVM->pad, 1);
289 break;
290 }
291
292 if (pFW->flags & FW_IMMEDIATE)
293 {
294 vmTextOut(pVM, "immediate", 1);
295 }
296

--- 21 unchanged lines hidden (view full) ---

318** VM up to debug the word: push IP, set the xt as the next thing to execute,
319** set a breakpoint at its first instruction, and run to the breakpoint.
320** Note: the semantics of this word are equivalent to "step in"
321**************************************************************************/
322void ficlDebugXT(FICL_VM *pVM)
323{
324 FICL_WORD *xt = stackPopPtr(pVM->pStack);
325 WORDKIND wk = ficlWordClassify(xt);
338 break;
339 }
340
341 if (pFW->flags & FW_IMMEDIATE)
342 {
343 vmTextOut(pVM, "immediate", 1);
344 }
345

--- 21 unchanged lines hidden (view full) ---

367** VM up to debug the word: push IP, set the xt as the next thing to execute,
368** set a breakpoint at its first instruction, and run to the breakpoint.
369** Note: the semantics of this word are equivalent to "step in"
370**************************************************************************/
371void ficlDebugXT(FICL_VM *pVM)
372{
373 FICL_WORD *xt = stackPopPtr(pVM->pStack);
374 WORDKIND wk = ficlWordClassify(xt);
326 FICL_WORD *pStep = ficlLookup("step-break");
327
375
328 assert(pStep);
329
330 stackPushPtr(pVM->pStack, xt);
331 seeXT(pVM);
332
333 switch (wk)
334 {
335 case COLON:
336 case DOES:
337 /*
338 ** Run the colon code and set a breakpoint at the next instruction
339 */
340 vmExecute(pVM, xt);
376 stackPushPtr(pVM->pStack, xt);
377 seeXT(pVM);
378
379 switch (wk)
380 {
381 case COLON:
382 case DOES:
383 /*
384 ** Run the colon code and set a breakpoint at the next instruction
385 */
386 vmExecute(pVM, xt);
341 bpStep.address = pVM->ip;
342 bpStep.origXT = *pVM->ip;
343 *pVM->ip = pStep;
387 vmSetBreak(pVM, &(pVM->pSys->bpStep));
344 break;
345
346 default:
347 vmExecute(pVM, xt);
348 break;
349 }
350
351 return;

--- 13 unchanged lines hidden (view full) ---

365 */
366 {
367 M_VM_STEP(pVM)
368 }
369
370 /*
371 ** Now set a breakpoint at the next instruction
372 */
388 break;
389
390 default:
391 vmExecute(pVM, xt);
392 break;
393 }
394
395 return;

--- 13 unchanged lines hidden (view full) ---

409 */
410 {
411 M_VM_STEP(pVM)
412 }
413
414 /*
415 ** Now set a breakpoint at the next instruction
416 */
373 vmSetBreak(pVM, &bpStep);
417 vmSetBreak(pVM, &(pVM->pSys->bpStep));
374
375 return;
376}
377
378
379/**************************************************************************
380 s t e p O v e r
381** FICL
382** Execute the next instruction atomically. This requires some insight into
383** the memory layout of compiled code. Set a breakpoint at the next instruction
384** in this word, and run until we hit it
385**************************************************************************/
386void stepOver(FICL_VM *pVM)
387{
388 FICL_WORD *pFW;
389 WORDKIND kind;
418
419 return;
420}
421
422
423/**************************************************************************
424 s t e p O v e r
425** FICL
426** Execute the next instruction atomically. This requires some insight into
427** the memory layout of compiled code. Set a breakpoint at the next instruction
428** in this word, and run until we hit it
429**************************************************************************/
430void stepOver(FICL_VM *pVM)
431{
432 FICL_WORD *pFW;
433 WORDKIND kind;
390 FICL_WORD *pStep = ficlLookup("step-break");
434 FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break");
391 assert(pStep);
392
393 pFW = *pVM->ip;
394 kind = ficlWordClassify(pFW);
395
396 switch (kind)
397 {
398 case COLON:
399 case DOES:
400 /*
401 ** assume that the next cell holds an instruction
402 ** set a breakpoint there and return to the inner interp
403 */
435 assert(pStep);
436
437 pFW = *pVM->ip;
438 kind = ficlWordClassify(pFW);
439
440 switch (kind)
441 {
442 case COLON:
443 case DOES:
444 /*
445 ** assume that the next cell holds an instruction
446 ** set a breakpoint there and return to the inner interp
447 */
404 bpStep.address = pVM->ip + 1;
405 bpStep.origXT = pVM->ip[1];
448 pVM->pSys->bpStep.address = pVM->ip + 1;
449 pVM->pSys->bpStep.origXT = pVM->ip[1];
406 pVM->ip[1] = pStep;
407 break;
408
409 default:
410 stepIn(pVM);
411 break;
412 }
413

--- 20 unchanged lines hidden (view full) ---

434void stepBreak(FICL_VM *pVM)
435{
436 STRINGINFO si;
437 FICL_WORD *pFW;
438 FICL_WORD *pOnStep;
439
440 if (!pVM->fRestart)
441 {
450 pVM->ip[1] = pStep;
451 break;
452
453 default:
454 stepIn(pVM);
455 break;
456 }
457

--- 20 unchanged lines hidden (view full) ---

478void stepBreak(FICL_VM *pVM)
479{
480 STRINGINFO si;
481 FICL_WORD *pFW;
482 FICL_WORD *pOnStep;
483
484 if (!pVM->fRestart)
485 {
442
443 assert(bpStep.address != NULL);
486 assert(pVM->pSys->bpStep.address);
487 assert(pVM->pSys->bpStep.origXT);
444 /*
445 ** Clear the breakpoint that caused me to run
446 ** Restore the original instruction at the breakpoint,
447 ** and restore the IP
448 */
488 /*
489 ** Clear the breakpoint that caused me to run
490 ** Restore the original instruction at the breakpoint,
491 ** and restore the IP
492 */
449 assert(bpStep.address);
450 assert(bpStep.origXT);
493 pVM->ip = (IPTYPE)(pVM->pSys->bpStep.address);
494 *pVM->ip = pVM->pSys->bpStep.origXT;
451
495
452 pVM->ip = (IPTYPE)bpStep.address;
453 *pVM->ip = bpStep.origXT;
454
455 /*
456 ** If there's an onStep, do it
457 */
496 /*
497 ** If there's an onStep, do it
498 */
458 pOnStep = ficlLookup("on-step");
499 pOnStep = ficlLookup(pVM->pSys, "on-step");
459 if (pOnStep)
460 ficlExecXT(pVM, pOnStep);
461
462 /*
463 ** Print the name of the next instruction
464 */
500 if (pOnStep)
501 ficlExecXT(pVM, pOnStep);
502
503 /*
504 ** Print the name of the next instruction
505 */
465 pFW = bpStep.origXT;
506 pFW = pVM->pSys->bpStep.origXT;
466 sprintf(pVM->pad, "next: %.*s", pFW->nName, pFW->name);
507 sprintf(pVM->pad, "next: %.*s", pFW->nName, pFW->name);
508#if 0
467 if (isPrimitive(pFW))
468 {
509 if (isPrimitive(pFW))
510 {
469 strcat(pVM->pad, " primitive");
511 strcat(pVM->pad, " ( primitive )");
470 }
512 }
513#endif
471
472 vmTextOut(pVM, pVM->pad, 1);
514
515 vmTextOut(pVM, pVM->pad, 1);
516 debugPrompt(pVM);
473 }
474 else
475 {
476 pVM->fRestart = 0;
477 }
478
479 si = vmGetWord(pVM);
480
481 if (!strincmp(si.cp, "i", si.count))
482 {
483 stepIn(pVM);
484 }
485 else if (!strincmp(si.cp, "g", si.count))
486 {
487 return;
488 }
517 }
518 else
519 {
520 pVM->fRestart = 0;
521 }
522
523 si = vmGetWord(pVM);
524
525 if (!strincmp(si.cp, "i", si.count))
526 {
527 stepIn(pVM);
528 }
529 else if (!strincmp(si.cp, "g", si.count))
530 {
531 return;
532 }
533 else if (!strincmp(si.cp, "l", si.count))
534 {
535 FICL_WORD *xt;
536 xt = findEnclosingWord(pVM, (CELL *)(pVM->ip));
537 if (xt)
538 {
539 stackPushPtr(pVM->pStack, xt);
540 seeXT(pVM);
541 }
542 else
543 {
544 vmTextOut(pVM, "sorry - can't do that", 1);
545 }
546 vmThrow(pVM, VM_RESTART);
547 }
489 else if (!strincmp(si.cp, "o", si.count))
490 {
491 stepOver(pVM);
492 }
493 else if (!strincmp(si.cp, "q", si.count))
494 {
548 else if (!strincmp(si.cp, "o", si.count))
549 {
550 stepOver(pVM);
551 }
552 else if (!strincmp(si.cp, "q", si.count))
553 {
554 ficlTextOut(pVM, FICL_PROMPT, 0);
495 vmThrow(pVM, VM_ABORT);
496 }
555 vmThrow(pVM, VM_ABORT);
556 }
557 else if (!strincmp(si.cp, "x", si.count))
558 {
559 /*
560 ** Take whatever's left in the TIB and feed it to a subordinate ficlExec
561 */
562 int ret;
563 char *cp = pVM->tib.cp + pVM->tib.index;
564 int count = pVM->tib.end - cp;
565 FICL_WORD *oldRun = pVM->runningWord;
566
567 ret = ficlExecC(pVM, cp, count);
568
569 if (ret == VM_OUTOFTEXT)
570 {
571 ret = VM_RESTART;
572 pVM->runningWord = oldRun;
573 vmTextOut(pVM, "", 1);
574 }
575
576 vmThrow(pVM, ret);
577 }
497 else
498 {
499 vmTextOut(pVM, "i -- step In", 1);
500 vmTextOut(pVM, "o -- step Over", 1);
501 vmTextOut(pVM, "g -- Go (execute to completion)", 1);
578 else
579 {
580 vmTextOut(pVM, "i -- step In", 1);
581 vmTextOut(pVM, "o -- step Over", 1);
582 vmTextOut(pVM, "g -- Go (execute to completion)", 1);
583 vmTextOut(pVM, "l -- List source code", 1);
502 vmTextOut(pVM, "q -- Quit (stop debugging and abort)", 1);
584 vmTextOut(pVM, "q -- Quit (stop debugging and abort)", 1);
503 vmTextOut(pVM, "x -- eXecute a single word", 1);
585 vmTextOut(pVM, "x -- eXecute the rest of the line as ficl words", 1);
586 debugPrompt(pVM);
504 vmThrow(pVM, VM_RESTART);
505 }
506
507 return;
508}
509
510
511/**************************************************************************

--- 9 unchanged lines hidden (view full) ---

521}
522
523
524/**************************************************************************
525 d i s p l a y S t a c k
526** TOOLS
527** Display the parameter stack (code for ".s")
528**************************************************************************/
587 vmThrow(pVM, VM_RESTART);
588 }
589
590 return;
591}
592
593
594/**************************************************************************

--- 9 unchanged lines hidden (view full) ---

604}
605
606
607/**************************************************************************
608 d i s p l a y S t a c k
609** TOOLS
610** Display the parameter stack (code for ".s")
611**************************************************************************/
529static void displayStack(FICL_VM *pVM)
612static void displayPStack(FICL_VM *pVM)
530{
613{
531 int d = stackDepth(pVM->pStack);
614 FICL_STACK *pStk = pVM->pStack;
615 int d = stackDepth(pStk);
532 int i;
533 CELL *pCell;
534
535 vmCheckStack(pVM, 0, 0);
536
537 if (d == 0)
538 vmTextOut(pVM, "(Stack Empty) ", 0);
539 else
540 {
616 int i;
617 CELL *pCell;
618
619 vmCheckStack(pVM, 0, 0);
620
621 if (d == 0)
622 vmTextOut(pVM, "(Stack Empty) ", 0);
623 else
624 {
541 pCell = pVM->pStack->base;
625 pCell = pStk->base;
542 for (i = 0; i < d; i++)
543 {
544 vmTextOut(pVM, ltoa((*pCell++).i, pVM->pad, pVM->base), 0);
545 vmTextOut(pVM, " ", 0);
546 }
547 }
626 for (i = 0; i < d; i++)
627 {
628 vmTextOut(pVM, ltoa((*pCell++).i, pVM->pad, pVM->base), 0);
629 vmTextOut(pVM, " ", 0);
630 }
631 }
632 return;
548}
549
550
551static void displayRStack(FICL_VM *pVM)
552{
633}
634
635
636static void displayRStack(FICL_VM *pVM)
637{
553 int d = stackDepth(pVM->rStack);
638 FICL_STACK *pStk = pVM->rStack;
639 int d = stackDepth(pStk);
554 int i;
555 CELL *pCell;
640 int i;
641 CELL *pCell;
642 FICL_DICT *dp = vmGetDict(pVM);
556
643
557 vmTextOut(pVM, "Return Stack: ", 0);
644 vmCheckStack(pVM, 0, 0);
645
558 if (d == 0)
646 if (d == 0)
559 vmTextOut(pVM, "Empty ", 0);
647 vmTextOut(pVM, "(Stack Empty) ", 0);
560 else
561 {
648 else
649 {
562 pCell = pVM->rStack->base;
650 pCell = pStk->base;
563 for (i = 0; i < d; i++)
564 {
651 for (i = 0; i < d; i++)
652 {
565 vmTextOut(pVM, ultoa((*pCell++).i, pVM->pad, 16), 0);
653 CELL c = *pCell++;
654 /*
655 ** Attempt to find the word that contains the
656 ** stacked address (as if it is part of a colon definition).
657 ** If this works, print the name of the word. Otherwise print
658 ** the value as a number.
659 */
660 if (dictIncludes(dp, c.p))
661 {
662 FICL_WORD *pFW = findEnclosingWord(pVM, c.p);
663 if (pFW)
664 {
665 int offset = (CELL *)c.p - &pFW->param[0];
666 sprintf(pVM->pad, "%s+%d ", pFW->name, offset);
667 vmTextOut(pVM, pVM->pad, 0);
668 continue; /* no need to print the numeric value */
669 }
670 }
671 vmTextOut(pVM, ltoa(c.i, pVM->pad, pVM->base), 0);
566 vmTextOut(pVM, " ", 0);
567 }
568 }
672 vmTextOut(pVM, " ", 0);
673 }
674 }
675
676 return;
569}
570
571
572/**************************************************************************
573 f o r g e t - w i d
574**
575**************************************************************************/
576static void forgetWid(FICL_VM *pVM)
577{
677}
678
679
680/**************************************************************************
681 f o r g e t - w i d
682**
683**************************************************************************/
684static void forgetWid(FICL_VM *pVM)
685{
578 FICL_DICT *pDict = ficlGetDict();
686 FICL_DICT *pDict = vmGetDict(pVM);
579 FICL_HASH *pHash;
580
581 pHash = (FICL_HASH *)stackPopPtr(pVM->pStack);
582 hashForget(pHash, pDict->here);
583
584 return;
585}
586

--- 8 unchanged lines hidden (view full) ---

595**
596** If the Search-Order word set is present, FORGET searches the
597** compilation word list. An ambiguous condition exists if the
598** compilation word list is deleted.
599**************************************************************************/
600static void forget(FICL_VM *pVM)
601{
602 void *where;
687 FICL_HASH *pHash;
688
689 pHash = (FICL_HASH *)stackPopPtr(pVM->pStack);
690 hashForget(pHash, pDict->here);
691
692 return;
693}
694

--- 8 unchanged lines hidden (view full) ---

703**
704** If the Search-Order word set is present, FORGET searches the
705** compilation word list. An ambiguous condition exists if the
706** compilation word list is deleted.
707**************************************************************************/
708static void forget(FICL_VM *pVM)
709{
710 void *where;
603 FICL_DICT *pDict = ficlGetDict();
711 FICL_DICT *pDict = vmGetDict(pVM);
604 FICL_HASH *pHash = pDict->pCompile;
605
606 ficlTick(pVM);
607 where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name;
608 hashForget(pHash, where);
609 pDict->here = PTRtoCELL where;
610
611 return;
612}
613
614
615/**************************************************************************
616 l i s t W o r d s
617**
618**************************************************************************/
619#define nCOLWIDTH 8
620static void listWords(FICL_VM *pVM)
621{
712 FICL_HASH *pHash = pDict->pCompile;
713
714 ficlTick(pVM);
715 where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name;
716 hashForget(pHash, where);
717 pDict->here = PTRtoCELL where;
718
719 return;
720}
721
722
723/**************************************************************************
724 l i s t W o r d s
725**
726**************************************************************************/
727#define nCOLWIDTH 8
728static void listWords(FICL_VM *pVM)
729{
622 FICL_DICT *dp = ficlGetDict();
730 FICL_DICT *dp = vmGetDict(pVM);
623 FICL_HASH *pHash = dp->pSearch[dp->nLists - 1];
624 FICL_WORD *wp;
625 int nChars = 0;
626 int len;
627 int y = 0;
628 unsigned i;
629 int nWords = 0;
630 char *cp;

--- 60 unchanged lines hidden (view full) ---

691
692
693/**************************************************************************
694 l i s t E n v
695** Print symbols defined in the environment
696**************************************************************************/
697static void listEnv(FICL_VM *pVM)
698{
731 FICL_HASH *pHash = dp->pSearch[dp->nLists - 1];
732 FICL_WORD *wp;
733 int nChars = 0;
734 int len;
735 int y = 0;
736 unsigned i;
737 int nWords = 0;
738 char *cp;

--- 60 unchanged lines hidden (view full) ---

799
800
801/**************************************************************************
802 l i s t E n v
803** Print symbols defined in the environment
804**************************************************************************/
805static void listEnv(FICL_VM *pVM)
806{
699 FICL_DICT *dp = ficlGetEnv();
807 FICL_DICT *dp = pVM->pSys->envp;
700 FICL_HASH *pHash = dp->pForthWords;
701 FICL_WORD *wp;
702 unsigned i;
703 int nWords = 0;
704
705 for (i = 0; i < pHash->size; i++)
706 {
707 for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)

--- 19 unchanged lines hidden (view full) ---

727 unsigned value;
728
729#if FICL_ROBUST > 1
730 vmCheckStack(pVM, 1, 0);
731#endif
732
733 vmGetWordToPad(pVM);
734 value = POPUNS();
808 FICL_HASH *pHash = dp->pForthWords;
809 FICL_WORD *wp;
810 unsigned i;
811 int nWords = 0;
812
813 for (i = 0; i < pHash->size; i++)
814 {
815 for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)

--- 19 unchanged lines hidden (view full) ---

835 unsigned value;
836
837#if FICL_ROBUST > 1
838 vmCheckStack(pVM, 1, 0);
839#endif
840
841 vmGetWordToPad(pVM);
842 value = POPUNS();
735 ficlSetEnv(pVM->pad, (FICL_UNS)value);
843 ficlSetEnv(pVM->pSys, pVM->pad, (FICL_UNS)value);
736 return;
737}
738
739static void env2Constant(FICL_VM *pVM)
740{
741 unsigned v1, v2;
742
743#if FICL_ROBUST > 1
744 vmCheckStack(pVM, 2, 0);
745#endif
746
747 vmGetWordToPad(pVM);
748 v2 = POPUNS();
749 v1 = POPUNS();
844 return;
845}
846
847static void env2Constant(FICL_VM *pVM)
848{
849 unsigned v1, v2;
850
851#if FICL_ROBUST > 1
852 vmCheckStack(pVM, 2, 0);
853#endif
854
855 vmGetWordToPad(pVM);
856 v2 = POPUNS();
857 v1 = POPUNS();
750 ficlSetEnvD(pVM->pad, v1, v2);
858 ficlSetEnvD(pVM->pSys, pVM->pad, v1, v2);
751 return;
752}
753
754
755/**************************************************************************
756 f i c l C o m p i l e T o o l s
757** Builds wordset for debugger and TOOLS optional word set
758**************************************************************************/
759
760void ficlCompileTools(FICL_SYSTEM *pSys)
761{
762 FICL_DICT *dp = pSys->dp;
763 assert (dp);
764
765 /*
766 ** TOOLS and TOOLS EXT
767 */
859 return;
860}
861
862
863/**************************************************************************
864 f i c l C o m p i l e T o o l s
865** Builds wordset for debugger and TOOLS optional word set
866**************************************************************************/
867
868void ficlCompileTools(FICL_SYSTEM *pSys)
869{
870 FICL_DICT *dp = pSys->dp;
871 assert (dp);
872
873 /*
874 ** TOOLS and TOOLS EXT
875 */
768 dictAppendWord(dp, ".r", displayRStack, FW_DEFAULT); /* guy carver */
769 dictAppendWord(dp, ".s", displayStack, FW_DEFAULT);
876 dictAppendWord(dp, ".s", displayPStack, FW_DEFAULT);
770 dictAppendWord(dp, "bye", bye, FW_DEFAULT);
771 dictAppendWord(dp, "forget", forget, FW_DEFAULT);
772 dictAppendWord(dp, "see", see, FW_DEFAULT);
773 dictAppendWord(dp, "words", listWords, FW_DEFAULT);
774
775 /*
776 ** Set TOOLS environment query values
777 */
877 dictAppendWord(dp, "bye", bye, FW_DEFAULT);
878 dictAppendWord(dp, "forget", forget, FW_DEFAULT);
879 dictAppendWord(dp, "see", see, FW_DEFAULT);
880 dictAppendWord(dp, "words", listWords, FW_DEFAULT);
881
882 /*
883 ** Set TOOLS environment query values
884 */
778 ficlSetEnv("tools", FICL_TRUE);
779 ficlSetEnv("tools-ext", FICL_FALSE);
885 ficlSetEnv(pSys, "tools", FICL_TRUE);
886 ficlSetEnv(pSys, "tools-ext", FICL_FALSE);
780
781 /*
782 ** Ficl extras
783 */
887
888 /*
889 ** Ficl extras
890 */
891 dictAppendWord(dp, "r.s", displayRStack, FW_DEFAULT); /* guy carver */
784 dictAppendWord(dp, ".env", listEnv, FW_DEFAULT);
785 dictAppendWord(dp, "env-constant",
786 envConstant, FW_DEFAULT);
787 dictAppendWord(dp, "env-2constant",
788 env2Constant, FW_DEFAULT);
789 dictAppendWord(dp, "debug-xt", ficlDebugXT, FW_DEFAULT);
790 dictAppendWord(dp, "parse-order",
791 ficlListParseSteps,
792 FW_DEFAULT);
793 dictAppendWord(dp, "step-break",stepBreak, FW_DEFAULT);
794 dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT);
795 dictAppendWord(dp, "see-xt", seeXT, FW_DEFAULT);
892 dictAppendWord(dp, ".env", listEnv, FW_DEFAULT);
893 dictAppendWord(dp, "env-constant",
894 envConstant, FW_DEFAULT);
895 dictAppendWord(dp, "env-2constant",
896 env2Constant, FW_DEFAULT);
897 dictAppendWord(dp, "debug-xt", ficlDebugXT, FW_DEFAULT);
898 dictAppendWord(dp, "parse-order",
899 ficlListParseSteps,
900 FW_DEFAULT);
901 dictAppendWord(dp, "step-break",stepBreak, FW_DEFAULT);
902 dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT);
903 dictAppendWord(dp, "see-xt", seeXT, FW_DEFAULT);
796 dictAppendWord(dp, ".r", displayRStack, FW_DEFAULT);
797
798 return;
799}
800
904
905 return;
906}
907