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.11 2001/12/05 07:21:34 jsadler Exp $
7 *******************************************************************/
8 /*
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 **
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
27 ** notice, this list of conditions and the following disclaimer in the
28 ** documentation and/or other materials provided with the distribution.
29 **
30 ** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
31 ** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
32 ** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
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
50 **
51 ** Step and break debugger for Ficl
52 ** debug ( xt -- ) Start debugging an xt
53 ** Set a breakpoint
54 ** Specify breakpoint default action
55 */
56
57
58 #ifdef TESTMAIN
59 #include <stdlib.h>
60 #include <stdio.h> /* sprintf */
61 #include <ctype.h>
62 #else
63 #include <stand.h>
64 #endif
65 #include <string.h>
66 #include "ficl.h"
67
68
69 #if 0
70 /*
71 ** nBREAKPOINTS sizes the breakpoint array. One breakpoint (bp 0) is reserved
72 ** for the STEP command. The rest are user programmable.
73 */
74 #define nBREAKPOINTS 32
75
76 #endif
77
78
79 /**************************************************************************
80 v m S e t B r e a k
81 ** Set a breakpoint at the current value of IP by
82 ** storing that address in a BREAKPOINT record
83 **************************************************************************/
vmSetBreak(FICL_VM * pVM,FICL_BREAKPOINT * pBP)84 static void vmSetBreak(FICL_VM *pVM, FICL_BREAKPOINT *pBP)
85 {
86 FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break");
87 assert(pStep);
88
89 pBP->address = pVM->ip;
90 pBP->origXT = *pVM->ip;
91 *pVM->ip = pStep;
92 }
93
94
95 /**************************************************************************
96 ** d e b u g P r o m p t
97 **************************************************************************/
debugPrompt(FICL_VM * pVM)98 static void debugPrompt(FICL_VM *pVM)
99 {
100 vmTextOut(pVM, "dbg> ", 0);
101 }
102
103
104 /**************************************************************************
105 ** i s A F i c l W o r d
106 ** Vet a candidate pointer carefully to make sure
107 ** it's not some chunk o' inline data...
108 ** It has to have a name, and it has to look
109 ** like it's in the dictionary address range.
110 ** NOTE: this excludes :noname words!
111 **************************************************************************/
isAFiclWord(FICL_DICT * pd,FICL_WORD * pFW)112 int isAFiclWord(FICL_DICT *pd, FICL_WORD *pFW)
113 {
114
115 if (!dictIncludes(pd, pFW))
116 return 0;
117
118 if (!dictIncludes(pd, pFW->name))
119 return 0;
120
121 if ((pFW->link != NULL) && !dictIncludes(pd, pFW->link))
122 return 0;
123
124 if ((pFW->nName <= 0) || (pFW->name[pFW->nName] != '\0'))
125 return 0;
126
127 if (strlen(pFW->name) != pFW->nName)
128 return 0;
129
130 return 1;
131 }
132
133
134 #if 0
135 static int isPrimitive(FICL_WORD *pFW)
136 {
137 WORDKIND wk = ficlWordClassify(pFW);
138 return ((wk != COLON) && (wk != DOES));
139 }
140 #endif
141
142
143 /**************************************************************************
144 f i n d E n c l o s i n g W o r d
145 ** Given a pointer to something, check to make sure it's an address in the
146 ** dictionary. If so, search backwards until we find something that looks
147 ** like a dictionary header. If successful, return the address of the
148 ** FICL_WORD found. Otherwise return NULL.
149 ** nSEARCH_CELLS sets the maximum neighborhood this func will search before giving up
150 **************************************************************************/
151 #define nSEARCH_CELLS 100
152
findEnclosingWord(FICL_VM * pVM,CELL * cp)153 static FICL_WORD *findEnclosingWord(FICL_VM *pVM, CELL *cp)
154 {
155 FICL_WORD *pFW;
156 FICL_DICT *pd = vmGetDict(pVM);
157 int i;
158
159 if (!dictIncludes(pd, (void *)cp))
160 return NULL;
161
162 for (i = nSEARCH_CELLS; i > 0; --i, --cp)
163 {
164 pFW = (FICL_WORD *)(cp + 1 - (sizeof (FICL_WORD) / sizeof (CELL)));
165 if (isAFiclWord(pd, pFW))
166 return pFW;
167 }
168
169 return NULL;
170 }
171
172
173 /**************************************************************************
174 s e e
175 ** TOOLS ( "<spaces>name" -- )
176 ** Display a human-readable representation of the named word's definition.
177 ** The source of the representation (object-code decompilation, source
178 ** block, etc.) and the particular form of the display is implementation
179 ** defined.
180 **************************************************************************/
181 /*
182 ** seeColon (for proctologists only)
183 ** Walks a colon definition, decompiling
184 ** on the fly. Knows about primitive control structures.
185 */
seeColon(FICL_VM * pVM,CELL * pc)186 static void seeColon(FICL_VM *pVM, CELL *pc)
187 {
188 char *cp;
189 CELL *param0 = pc;
190 FICL_DICT *pd = vmGetDict(pVM);
191 FICL_WORD *pSemiParen = ficlLookup(pVM->pSys, "(;)");
192 assert(pSemiParen);
193
194 for (; pc->p != pSemiParen; pc++)
195 {
196 FICL_WORD *pFW = (FICL_WORD *)(pc->p);
197
198 cp = pVM->pad;
199 if ((void *)pc == (void *)pVM->ip)
200 *cp++ = '>';
201 else
202 *cp++ = ' ';
203 cp += sprintf(cp, "%3d ", (int)(pc-param0));
204
205 if (isAFiclWord(pd, pFW))
206 {
207 WORDKIND kind = ficlWordClassify(pFW);
208 CELL c;
209
210 switch (kind)
211 {
212 case LITERAL:
213 c = *++pc;
214 if (isAFiclWord(pd, c.p))
215 {
216 FICL_WORD *pLit = (FICL_WORD *)c.p;
217 sprintf(cp, "%.*s ( %#lx literal )",
218 pLit->nName, pLit->name, (unsigned long)c.u);
219 }
220 else
221 sprintf(cp, "literal %ld (%#lx)",
222 (long)c.i, (unsigned long)c.u);
223 break;
224 case STRINGLIT:
225 {
226 FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
227 pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
228 sprintf(cp, "s\" %.*s\"", sp->count, sp->text);
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;
238 case IF:
239 c = *++pc;
240 if (c.i > 0)
241 sprintf(cp, "if / while (branch %d)", (int)(pc+c.i-param0));
242 else
243 sprintf(cp, "until (branch %d)", (int)(pc+c.i-param0));
244 break;
245 case BRANCH:
246 c = *++pc;
247 if (c.i == 0)
248 sprintf(cp, "repeat (branch %d)", (int)(pc+c.i-param0));
249 else if (c.i == 1)
250 sprintf(cp, "else (branch %d)", (int)(pc+c.i-param0));
251 else
252 sprintf(cp, "endof (branch %d)", (int)(pc+c.i-param0));
253 break;
254
255 case OF:
256 c = *++pc;
257 sprintf(cp, "of (branch %d)", (int)(pc+c.i-param0));
258 break;
259
260 case QDO:
261 c = *++pc;
262 sprintf(cp, "?do (leave %d)", (int)((CELL *)c.p-param0));
263 break;
264 case DO:
265 c = *++pc;
266 sprintf(cp, "do (leave %d)", (int)((CELL *)c.p-param0));
267 break;
268 case LOOP:
269 c = *++pc;
270 sprintf(cp, "loop (branch %d)", (int)(pc+c.i-param0));
271 break;
272 case PLOOP:
273 c = *++pc;
274 sprintf(cp, "+loop (branch %d)", (int)(pc+c.i-param0));
275 break;
276 default:
277 sprintf(cp, "%.*s", pFW->nName, pFW->name);
278 break;
279 }
280
281 }
282 else /* probably not a word - punt and print value */
283 {
284 sprintf(cp, "%ld ( %#lx )", (long)pc->i, (unsigned long)pc->u);
285 }
286
287 vmTextOut(pVM, pVM->pad, 1);
288 }
289
290 vmTextOut(pVM, ";", 1);
291 }
292
293 /*
294 ** Here's the outer part of the decompiler. It's
295 ** just a big nested conditional that checks the
296 ** CFA of the word to decompile for each kind of
297 ** known word-builder code, and tries to do
298 ** something appropriate. If the CFA is not recognized,
299 ** just indicate that it is a primitive.
300 */
seeXT(FICL_VM * pVM)301 static void seeXT(FICL_VM *pVM)
302 {
303 FICL_WORD *pFW;
304 WORDKIND kind;
305
306 pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
307 kind = ficlWordClassify(pFW);
308
309 switch (kind)
310 {
311 case COLON:
312 sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name);
313 vmTextOut(pVM, pVM->pad, 1);
314 seeColon(pVM, pFW->param);
315 break;
316
317 case DOES:
318 vmTextOut(pVM, "does>", 1);
319 seeColon(pVM, (CELL *)pFW->param->p);
320 break;
321
322 case CREATE:
323 vmTextOut(pVM, "create", 1);
324 break;
325
326 case VARIABLE:
327 sprintf(pVM->pad, "variable = %ld (%#lx)",
328 (long)pFW->param->i, (unsigned long)pFW->param->u);
329 vmTextOut(pVM, pVM->pad, 1);
330 break;
331
332 #if FICL_WANT_USER
333 case USER:
334 sprintf(pVM->pad, "user variable %ld (%#lx)",
335 (long)pFW->param->i, (unsigned long)pFW->param->u);
336 vmTextOut(pVM, pVM->pad, 1);
337 break;
338 #endif
339
340 case CONSTANT:
341 sprintf(pVM->pad, "constant = %ld (%#lx)",
342 (long)pFW->param->i, (unsigned long)pFW->param->u);
343 vmTextOut(pVM, pVM->pad, 1);
344
345 default:
346 sprintf(pVM->pad, "%.*s is a primitive", pFW->nName, pFW->name);
347 vmTextOut(pVM, pVM->pad, 1);
348 break;
349 }
350
351 if (pFW->flags & FW_IMMEDIATE)
352 {
353 vmTextOut(pVM, "immediate", 1);
354 }
355
356 if (pFW->flags & FW_COMPILE)
357 {
358 vmTextOut(pVM, "compile-only", 1);
359 }
360
361 return;
362 }
363
364
see(FICL_VM * pVM)365 static void see(FICL_VM *pVM)
366 {
367 ficlTick(pVM);
368 seeXT(pVM);
369 return;
370 }
371
372
373 /**************************************************************************
374 f i c l D e b u g X T
375 ** debug ( xt -- )
376 ** Given an xt of a colon definition or a word defined by DOES>, set the
377 ** VM up to debug the word: push IP, set the xt as the next thing to execute,
378 ** set a breakpoint at its first instruction, and run to the breakpoint.
379 ** Note: the semantics of this word are equivalent to "step in"
380 **************************************************************************/
ficlDebugXT(FICL_VM * pVM)381 void ficlDebugXT(FICL_VM *pVM)
382 {
383 FICL_WORD *xt = stackPopPtr(pVM->pStack);
384 WORDKIND wk = ficlWordClassify(xt);
385
386 stackPushPtr(pVM->pStack, xt);
387 seeXT(pVM);
388
389 switch (wk)
390 {
391 case COLON:
392 case DOES:
393 /*
394 ** Run the colon code and set a breakpoint at the next instruction
395 */
396 vmExecute(pVM, xt);
397 vmSetBreak(pVM, &(pVM->pSys->bpStep));
398 break;
399
400 default:
401 vmExecute(pVM, xt);
402 break;
403 }
404
405 return;
406 }
407
408
409 /**************************************************************************
410 s t e p I n
411 ** FICL
412 ** Execute the next instruction, stepping into it if it's a colon definition
413 ** or a does> word. This is the easy kind of step.
414 **************************************************************************/
stepIn(FICL_VM * pVM)415 void stepIn(FICL_VM *pVM)
416 {
417 /*
418 ** Do one step of the inner loop
419 */
420 {
421 M_VM_STEP(pVM)
422 }
423
424 /*
425 ** Now set a breakpoint at the next instruction
426 */
427 vmSetBreak(pVM, &(pVM->pSys->bpStep));
428
429 return;
430 }
431
432
433 /**************************************************************************
434 s t e p O v e r
435 ** FICL
436 ** Execute the next instruction atomically. This requires some insight into
437 ** the memory layout of compiled code. Set a breakpoint at the next instruction
438 ** in this word, and run until we hit it
439 **************************************************************************/
stepOver(FICL_VM * pVM)440 void stepOver(FICL_VM *pVM)
441 {
442 FICL_WORD *pFW;
443 WORDKIND kind;
444 FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break");
445 assert(pStep);
446
447 pFW = *pVM->ip;
448 kind = ficlWordClassify(pFW);
449
450 switch (kind)
451 {
452 case COLON:
453 case DOES:
454 /*
455 ** assume that the next cell holds an instruction
456 ** set a breakpoint there and return to the inner interp
457 */
458 pVM->pSys->bpStep.address = pVM->ip + 1;
459 pVM->pSys->bpStep.origXT = pVM->ip[1];
460 pVM->ip[1] = pStep;
461 break;
462
463 default:
464 stepIn(pVM);
465 break;
466 }
467
468 return;
469 }
470
471
472 /**************************************************************************
473 s t e p - b r e a k
474 ** FICL
475 ** Handles breakpoints for stepped execution.
476 ** Upon entry, bpStep contains the address and replaced instruction
477 ** of the current breakpoint.
478 ** Clear the breakpoint
479 ** Get a command from the console.
480 ** i (step in) - execute the current instruction and set a new breakpoint
481 ** at the IP
482 ** o (step over) - execute the current instruction to completion and set
483 ** a new breakpoint at the IP
484 ** g (go) - execute the current instruction and exit
485 ** q (quit) - abort current word
486 ** b (toggle breakpoint)
487 **************************************************************************/
stepBreak(FICL_VM * pVM)488 void stepBreak(FICL_VM *pVM)
489 {
490 STRINGINFO si;
491 FICL_WORD *pFW;
492 FICL_WORD *pOnStep;
493
494 if (!pVM->fRestart)
495 {
496 assert(pVM->pSys->bpStep.address);
497 assert(pVM->pSys->bpStep.origXT);
498 /*
499 ** Clear the breakpoint that caused me to run
500 ** Restore the original instruction at the breakpoint,
501 ** and restore the IP
502 */
503 pVM->ip = (IPTYPE)(pVM->pSys->bpStep.address);
504 *pVM->ip = pVM->pSys->bpStep.origXT;
505
506 /*
507 ** If there's an onStep, do it
508 */
509 pOnStep = ficlLookup(pVM->pSys, "on-step");
510 if (pOnStep)
511 ficlExecXT(pVM, pOnStep);
512
513 /*
514 ** Print the name of the next instruction
515 */
516 pFW = pVM->pSys->bpStep.origXT;
517 sprintf(pVM->pad, "next: %.*s", pFW->nName, pFW->name);
518 #if 0
519 if (isPrimitive(pFW))
520 {
521 strcat(pVM->pad, " ( primitive )");
522 }
523 #endif
524
525 vmTextOut(pVM, pVM->pad, 1);
526 debugPrompt(pVM);
527 }
528 else
529 {
530 pVM->fRestart = 0;
531 }
532
533 si = vmGetWord(pVM);
534
535 if (!strincmp(si.cp, "i", si.count))
536 {
537 stepIn(pVM);
538 }
539 else if (!strincmp(si.cp, "g", si.count))
540 {
541 return;
542 }
543 else if (!strincmp(si.cp, "l", si.count))
544 {
545 FICL_WORD *xt;
546 xt = findEnclosingWord(pVM, (CELL *)(pVM->ip));
547 if (xt)
548 {
549 stackPushPtr(pVM->pStack, xt);
550 seeXT(pVM);
551 }
552 else
553 {
554 vmTextOut(pVM, "sorry - can't do that", 1);
555 }
556 vmThrow(pVM, VM_RESTART);
557 }
558 else if (!strincmp(si.cp, "o", si.count))
559 {
560 stepOver(pVM);
561 }
562 else if (!strincmp(si.cp, "q", si.count))
563 {
564 ficlTextOut(pVM, FICL_PROMPT, 0);
565 vmThrow(pVM, VM_ABORT);
566 }
567 else if (!strincmp(si.cp, "x", si.count))
568 {
569 /*
570 ** Take whatever's left in the TIB and feed it to a subordinate ficlExec
571 */
572 int ret;
573 char *cp = pVM->tib.cp + pVM->tib.index;
574 int count = pVM->tib.end - cp;
575 FICL_WORD *oldRun = pVM->runningWord;
576
577 ret = ficlExecC(pVM, cp, count);
578
579 if (ret == VM_OUTOFTEXT)
580 {
581 ret = VM_RESTART;
582 pVM->runningWord = oldRun;
583 vmTextOut(pVM, "", 1);
584 }
585
586 vmThrow(pVM, ret);
587 }
588 else
589 {
590 vmTextOut(pVM, "i -- step In", 1);
591 vmTextOut(pVM, "o -- step Over", 1);
592 vmTextOut(pVM, "g -- Go (execute to completion)", 1);
593 vmTextOut(pVM, "l -- List source code", 1);
594 vmTextOut(pVM, "q -- Quit (stop debugging and abort)", 1);
595 vmTextOut(pVM, "x -- eXecute the rest of the line as ficl words", 1);
596 debugPrompt(pVM);
597 vmThrow(pVM, VM_RESTART);
598 }
599
600 return;
601 }
602
603
604 /**************************************************************************
605 b y e
606 ** TOOLS
607 ** Signal the system to shut down - this causes ficlExec to return
608 ** VM_USEREXIT. The rest is up to you.
609 **************************************************************************/
bye(FICL_VM * pVM)610 static void bye(FICL_VM *pVM)
611 {
612 vmThrow(pVM, VM_USEREXIT);
613 return;
614 }
615
616
617 /**************************************************************************
618 d i s p l a y S t a c k
619 ** TOOLS
620 ** Display the parameter stack (code for ".s")
621 **************************************************************************/
displayPStack(FICL_VM * pVM)622 static void displayPStack(FICL_VM *pVM)
623 {
624 FICL_STACK *pStk = pVM->pStack;
625 int d = stackDepth(pStk);
626 int i;
627 CELL *pCell;
628
629 vmCheckStack(pVM, 0, 0);
630
631 if (d == 0)
632 vmTextOut(pVM, "(Stack Empty) ", 0);
633 else
634 {
635 pCell = pStk->base;
636 for (i = 0; i < d; i++)
637 {
638 vmTextOut(pVM, ltoa((*pCell++).i, pVM->pad, pVM->base), 0);
639 vmTextOut(pVM, " ", 0);
640 }
641 }
642 return;
643 }
644
645
displayRStack(FICL_VM * pVM)646 static void displayRStack(FICL_VM *pVM)
647 {
648 FICL_STACK *pStk = pVM->rStack;
649 int d = stackDepth(pStk);
650 int i;
651 CELL *pCell;
652 FICL_DICT *dp = vmGetDict(pVM);
653
654 vmCheckStack(pVM, 0, 0);
655
656 if (d == 0)
657 vmTextOut(pVM, "(Stack Empty) ", 0);
658 else
659 {
660 pCell = pStk->base;
661 for (i = 0; i < d; i++)
662 {
663 CELL c = *pCell++;
664 /*
665 ** Attempt to find the word that contains the
666 ** stacked address (as if it is part of a colon definition).
667 ** If this works, print the name of the word. Otherwise print
668 ** the value as a number.
669 */
670 if (dictIncludes(dp, c.p))
671 {
672 FICL_WORD *pFW = findEnclosingWord(pVM, c.p);
673 if (pFW)
674 {
675 int offset = (CELL *)c.p - &pFW->param[0];
676 sprintf(pVM->pad, "%s+%d ", pFW->name, offset);
677 vmTextOut(pVM, pVM->pad, 0);
678 continue; /* no need to print the numeric value */
679 }
680 }
681 vmTextOut(pVM, ltoa(c.i, pVM->pad, pVM->base), 0);
682 vmTextOut(pVM, " ", 0);
683 }
684 }
685
686 return;
687 }
688
689
690 /**************************************************************************
691 f o r g e t - w i d
692 **
693 **************************************************************************/
forgetWid(FICL_VM * pVM)694 static void forgetWid(FICL_VM *pVM)
695 {
696 FICL_DICT *pDict = vmGetDict(pVM);
697 FICL_HASH *pHash;
698
699 pHash = (FICL_HASH *)stackPopPtr(pVM->pStack);
700 hashForget(pHash, pDict->here);
701
702 return;
703 }
704
705
706 /**************************************************************************
707 f o r g e t
708 ** TOOLS EXT ( "<spaces>name" -- )
709 ** Skip leading space delimiters. Parse name delimited by a space.
710 ** Find name, then delete name from the dictionary along with all
711 ** words added to the dictionary after name. An ambiguous
712 ** condition exists if name cannot be found.
713 **
714 ** If the Search-Order word set is present, FORGET searches the
715 ** compilation word list. An ambiguous condition exists if the
716 ** compilation word list is deleted.
717 **************************************************************************/
forget(FICL_VM * pVM)718 static void forget(FICL_VM *pVM)
719 {
720 void *where;
721 FICL_DICT *pDict = vmGetDict(pVM);
722 FICL_HASH *pHash = pDict->pCompile;
723
724 ficlTick(pVM);
725 where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name;
726 hashForget(pHash, where);
727 pDict->here = PTRtoCELL where;
728
729 return;
730 }
731
732
733 /**************************************************************************
734 l i s t W o r d s
735 **
736 **************************************************************************/
737 #define nCOLWIDTH 8
listWords(FICL_VM * pVM)738 static void listWords(FICL_VM *pVM)
739 {
740 FICL_DICT *dp = vmGetDict(pVM);
741 FICL_HASH *pHash = dp->pSearch[dp->nLists - 1];
742 FICL_WORD *wp;
743 int nChars = 0;
744 int len;
745 int y = 0;
746 unsigned i;
747 int nWords = 0;
748 char *cp;
749 char *pPad = pVM->pad;
750
751 for (i = 0; i < pHash->size; i++)
752 {
753 for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
754 {
755 if (wp->nName == 0) /* ignore :noname defs */
756 continue;
757
758 cp = wp->name;
759 nChars += sprintf(pPad + nChars, "%s", cp);
760
761 if (nChars > 70)
762 {
763 pPad[nChars] = '\0';
764 nChars = 0;
765 y++;
766 if(y>23) {
767 y=0;
768 vmTextOut(pVM, "--- Press Enter to continue ---",0);
769 getchar();
770 vmTextOut(pVM,"\r",0);
771 }
772 vmTextOut(pVM, pPad, 1);
773 }
774 else
775 {
776 len = nCOLWIDTH - nChars % nCOLWIDTH;
777 while (len-- > 0)
778 pPad[nChars++] = ' ';
779 }
780
781 if (nChars > 70)
782 {
783 pPad[nChars] = '\0';
784 nChars = 0;
785 y++;
786 if(y>23) {
787 y=0;
788 vmTextOut(pVM, "--- Press Enter to continue ---",0);
789 getchar();
790 vmTextOut(pVM,"\r",0);
791 }
792 vmTextOut(pVM, pPad, 1);
793 }
794 }
795 }
796
797 if (nChars > 0)
798 {
799 pPad[nChars] = '\0';
800 nChars = 0;
801 vmTextOut(pVM, pPad, 1);
802 }
803
804 sprintf(pVM->pad, "Dictionary: %d words, %ld cells used of %u total",
805 nWords, (long) (dp->here - dp->dict), dp->size);
806 vmTextOut(pVM, pVM->pad, 1);
807 return;
808 }
809
810
811 /**************************************************************************
812 l i s t E n v
813 ** Print symbols defined in the environment
814 **************************************************************************/
listEnv(FICL_VM * pVM)815 static void listEnv(FICL_VM *pVM)
816 {
817 FICL_DICT *dp = pVM->pSys->envp;
818 FICL_HASH *pHash = dp->pForthWords;
819 FICL_WORD *wp;
820 unsigned i;
821 int nWords = 0;
822
823 for (i = 0; i < pHash->size; i++)
824 {
825 for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
826 {
827 vmTextOut(pVM, wp->name, 1);
828 }
829 }
830
831 sprintf(pVM->pad, "Environment: %d words, %ld cells used of %u total",
832 nWords, (long) (dp->here - dp->dict), dp->size);
833 vmTextOut(pVM, pVM->pad, 1);
834 return;
835 }
836
837
838 /**************************************************************************
839 e n v C o n s t a n t
840 ** Ficl interface to ficlSetEnv and ficlSetEnvD - allow ficl code to set
841 ** environment constants...
842 **************************************************************************/
envConstant(FICL_VM * pVM)843 static void envConstant(FICL_VM *pVM)
844 {
845 unsigned value;
846
847 #if FICL_ROBUST > 1
848 vmCheckStack(pVM, 1, 0);
849 #endif
850
851 vmGetWordToPad(pVM);
852 value = POPUNS();
853 ficlSetEnv(pVM->pSys, pVM->pad, (FICL_UNS)value);
854 return;
855 }
856
env2Constant(FICL_VM * pVM)857 static void env2Constant(FICL_VM *pVM)
858 {
859 unsigned v1, v2;
860
861 #if FICL_ROBUST > 1
862 vmCheckStack(pVM, 2, 0);
863 #endif
864
865 vmGetWordToPad(pVM);
866 v2 = POPUNS();
867 v1 = POPUNS();
868 ficlSetEnvD(pVM->pSys, pVM->pad, v1, v2);
869 return;
870 }
871
872
873 /**************************************************************************
874 f i c l C o m p i l e T o o l s
875 ** Builds wordset for debugger and TOOLS optional word set
876 **************************************************************************/
877
ficlCompileTools(FICL_SYSTEM * pSys)878 void ficlCompileTools(FICL_SYSTEM *pSys)
879 {
880 FICL_DICT *dp = pSys->dp;
881 assert (dp);
882
883 /*
884 ** TOOLS and TOOLS EXT
885 */
886 dictAppendWord(dp, ".s", displayPStack, FW_DEFAULT);
887 dictAppendWord(dp, "bye", bye, FW_DEFAULT);
888 dictAppendWord(dp, "forget", forget, FW_DEFAULT);
889 dictAppendWord(dp, "see", see, FW_DEFAULT);
890 dictAppendWord(dp, "words", listWords, FW_DEFAULT);
891
892 /*
893 ** Set TOOLS environment query values
894 */
895 ficlSetEnv(pSys, "tools", FICL_TRUE);
896 ficlSetEnv(pSys, "tools-ext", FICL_FALSE);
897
898 /*
899 ** Ficl extras
900 */
901 dictAppendWord(dp, "r.s", displayRStack, FW_DEFAULT); /* guy carver */
902 dictAppendWord(dp, ".env", listEnv, FW_DEFAULT);
903 dictAppendWord(dp, "env-constant",
904 envConstant, FW_DEFAULT);
905 dictAppendWord(dp, "env-2constant",
906 env2Constant, FW_DEFAULT);
907 dictAppendWord(dp, "debug-xt", ficlDebugXT, FW_DEFAULT);
908 dictAppendWord(dp, "parse-order",
909 ficlListParseSteps,
910 FW_DEFAULT);
911 dictAppendWord(dp, "step-break",stepBreak, FW_DEFAULT);
912 dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT);
913 dictAppendWord(dp, "see-xt", seeXT, FW_DEFAULT);
914
915 return;
916 }
917
918