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