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