xref: /illumos-gate/usr/src/common/ficl/tools.c (revision 1fb83a8f)
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.12 2010/08/12 13:57:22 asau 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  * fiColonParen fiDoDoes createParen fiVariableParen fiUserParen fiConstantParen
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 #include <stdbool.h>
58 #include "ficl.h"
59 
60 extern void exit(int);
61 
62 static void ficlPrimitiveStepIn(ficlVm *vm);
63 static void ficlPrimitiveStepOver(ficlVm *vm);
64 static void ficlPrimitiveStepBreak(ficlVm *vm);
65 
66 void
67 ficlCallbackAssert(ficlCallback *callback, int expression,
68     char *expressionString, char *filename, int line)
69 {
70 #if FICL_ROBUST >= 1
71 	if (!expression) {
72 		static char buffer[256];
73 		sprintf(buffer, "ASSERTION FAILED at %s:%d: \"%s\"\n",
74 		    filename, line, expressionString);
75 		ficlCallbackTextOut(callback, buffer);
76 		exit(-1);
77 	}
78 #else /* FICL_ROBUST >= 1 */
79 	FICL_IGNORE(callback);
80 	FICL_IGNORE(expression);
81 	FICL_IGNORE(expressionString);
82 	FICL_IGNORE(filename);
83 	FICL_IGNORE(line);
84 #endif /* FICL_ROBUST >= 1 */
85 }
86 
87 /*
88  * v m S e t B r e a k
89  * Set a breakpoint at the current value of IP by
90  * storing that address in a BREAKPOINT record
91  */
92 static void
93 ficlVmSetBreak(ficlVm *vm, ficlBreakpoint *pBP)
94 {
95 	ficlWord *pStep = ficlSystemLookup(vm->callback.system, "step-break");
96 	FICL_VM_ASSERT(vm, pStep);
97 
98 	pBP->address = vm->ip;
99 	pBP->oldXT = *vm->ip;
100 	*vm->ip = pStep;
101 }
102 
103 /*
104  * d e b u g P r o m p t
105  */
106 static void
107 ficlDebugPrompt(bool debug)
108 {
109 	if (debug)
110 		setenv("prompt", "dbg> ", 1);
111 	else
112 		setenv("prompt", "${interpret}", 1);
113 }
114 
115 #if 0
116 static int
117 isPrimitive(ficlWord *word)
118 {
119 	ficlWordKind wk = ficlWordClassify(word);
120 	return ((wk != COLON) && (wk != DOES));
121 }
122 #endif
123 
124 /*
125  * d i c t H a s h S u m m a r y
126  * Calculate a figure of merit for the dictionary hash table based
127  * on the average search depth for all the words in the dictionary,
128  * assuming uniform distribution of target keys. The figure of merit
129  * is the ratio of the total search depth for all keys in the table
130  * versus a theoretical optimum that would be achieved if the keys
131  * were distributed into the table as evenly as possible.
132  * The figure would be worse if the hash table used an open
133  * addressing scheme (i.e. collisions resolved by searching the
134  * table for an empty slot) for a given size table.
135  */
136 #if FICL_WANT_FLOAT
137 void
138 ficlPrimitiveHashSummary(ficlVm *vm)
139 {
140 	ficlDictionary *dictionary = ficlVmGetDictionary(vm);
141 	ficlHash *pFHash;
142 	ficlWord **hash;
143 	unsigned size;
144 	ficlWord *word;
145 	unsigned i;
146 	int nMax = 0;
147 	int nWords = 0;
148 	int nFilled;
149 	double avg = 0.0;
150 	double best;
151 	int nAvg, nRem, nDepth;
152 
153 	FICL_VM_DICTIONARY_CHECK(vm, dictionary, 0);
154 
155 	pFHash = dictionary->wordlists[dictionary->wordlistCount - 1];
156 	hash = pFHash->table;
157 	size = pFHash->size;
158 	nFilled = size;
159 
160 	for (i = 0; i < size; i++) {
161 		int n = 0;
162 		word = hash[i];
163 
164 		while (word) {
165 			++n;
166 			++nWords;
167 			word = word->link;
168 		}
169 
170 		avg += (double)(n * (n+1)) / 2.0;
171 
172 		if (n > nMax)
173 			nMax = n;
174 		if (n == 0)
175 			--nFilled;
176 	}
177 
178 	/* Calc actual avg search depth for this hash */
179 	avg = avg / nWords;
180 
181 	/* Calc best possible performance with this size hash */
182 	nAvg = nWords / size;
183 	nRem = nWords % size;
184 	nDepth = size * (nAvg * (nAvg+1))/2 + (nAvg+1)*nRem;
185 	best = (double)nDepth/nWords;
186 
187 	sprintf(vm->pad, "%d bins, %2.0f%% filled, Depth: "
188 	    "Max=%d, Avg=%2.1f, Best=%2.1f, Score: %2.0f%%\n",
189 	    size, (double)nFilled * 100.0 / size, nMax,
190 	    avg, best, 100.0 * best / avg);
191 
192 	ficlVmTextOut(vm, vm->pad);
193 }
194 #endif
195 
196 /*
197  * Here's the outer part of the decompiler. It's
198  * just a big nested conditional that checks the
199  * CFA of the word to decompile for each kind of
200  * known word-builder code, and tries to do
201  * something appropriate. If the CFA is not recognized,
202  * just indicate that it is a primitive.
203  */
204 static void
205 ficlPrimitiveSeeXT(ficlVm *vm)
206 {
207 	ficlWord *word;
208 	ficlWordKind kind;
209 
210 	word = (ficlWord *)ficlStackPopPointer(vm->dataStack);
211 	kind = ficlWordClassify(word);
212 
213 	switch (kind) {
214 	case FICL_WORDKIND_COLON:
215 		sprintf(vm->pad, ": %.*s\n", word->length, word->name);
216 		ficlVmTextOut(vm, vm->pad);
217 		ficlDictionarySee(ficlVmGetDictionary(vm), word,
218 		    &(vm->callback));
219 	break;
220 	case FICL_WORDKIND_DOES:
221 		ficlVmTextOut(vm, "does>\n");
222 		ficlDictionarySee(ficlVmGetDictionary(vm),
223 		    (ficlWord *)word->param->p, &(vm->callback));
224 	break;
225 	case FICL_WORDKIND_CREATE:
226 		ficlVmTextOut(vm, "create\n");
227 	break;
228 	case FICL_WORDKIND_VARIABLE:
229 		sprintf(vm->pad, "variable = %ld (%#lx)\n",
230 		    (long)word->param->i, (long unsigned)word->param->u);
231 		ficlVmTextOut(vm, vm->pad);
232 	break;
233 #if FICL_WANT_USER
234 	case FICL_WORDKIND_USER:
235 		sprintf(vm->pad, "user variable %ld (%#lx)\n",
236 		    (long)word->param->i, (long unsigned)word->param->u);
237 		ficlVmTextOut(vm, vm->pad);
238 	break;
239 #endif
240 	case FICL_WORDKIND_CONSTANT:
241 		sprintf(vm->pad, "constant = %ld (%#lx)\n",
242 		    (long)word->param->i, (long unsigned)word->param->u);
243 		ficlVmTextOut(vm, vm->pad);
244 	break;
245 	case FICL_WORDKIND_2CONSTANT:
246 		sprintf(vm->pad, "constant = %ld %ld (%#lx %#lx)\n",
247 		    (long)word->param[1].i, (long)word->param->i,
248 		    (long unsigned)word->param[1].u,
249 		    (long unsigned)word->param->u);
250 		ficlVmTextOut(vm, vm->pad);
251 	break;
252 
253 	default:
254 		sprintf(vm->pad, "%.*s is a primitive\n", word->length,
255 		    word->name);
256 		ficlVmTextOut(vm, vm->pad);
257 	break;
258 	}
259 
260 	if (word->flags & FICL_WORD_IMMEDIATE) {
261 		ficlVmTextOut(vm, "immediate\n");
262 	}
263 
264 	if (word->flags & FICL_WORD_COMPILE_ONLY) {
265 		ficlVmTextOut(vm, "compile-only\n");
266 	}
267 }
268 
269 static void
270 ficlPrimitiveSee(ficlVm *vm)
271 {
272 	ficlPrimitiveTick(vm);
273 	ficlPrimitiveSeeXT(vm);
274 }
275 
276 /*
277  * f i c l D e b u g X T
278  * debug  ( xt -- )
279  * Given an xt of a colon definition or a word defined by DOES>, set the
280  * VM up to debug the word: push IP, set the xt as the next thing to execute,
281  * set a breakpoint at its first instruction, and run to the breakpoint.
282  * Note: the semantics of this word are equivalent to "step in"
283  */
284 static void
285 ficlPrimitiveDebugXT(ficlVm *vm)
286 {
287 	ficlWord *xt = ficlStackPopPointer(vm->dataStack);
288 	ficlWordKind wk = ficlWordClassify(xt);
289 
290 	ficlStackPushPointer(vm->dataStack, xt);
291 	ficlPrimitiveSeeXT(vm);
292 
293 	switch (wk) {
294 	case FICL_WORDKIND_COLON:
295 	case FICL_WORDKIND_DOES:
296 		/*
297 		 * Run the colon code and set a breakpoint at the next
298 		 * instruction
299 		 */
300 		ficlVmExecuteWord(vm, xt);
301 		ficlVmSetBreak(vm, &(vm->callback.system->breakpoint));
302 	break;
303 	default:
304 		ficlVmExecuteWord(vm, xt);
305 	break;
306 	}
307 }
308 
309 /*
310  * s t e p I n
311  * Ficl
312  * Execute the next instruction, stepping into it if it's a colon definition
313  * or a does> word. This is the easy kind of step.
314  */
315 static void
316 ficlPrimitiveStepIn(ficlVm *vm)
317 {
318 	/*
319 	 * Do one step of the inner loop
320 	 */
321 	ficlVmExecuteWord(vm, *vm->ip++);
322 
323 	/*
324 	 * Now set a breakpoint at the next instruction
325 	 */
326 	ficlVmSetBreak(vm, &(vm->callback.system->breakpoint));
327 }
328 
329 /*
330  * s t e p O v e r
331  * Ficl
332  * Execute the next instruction atomically. This requires some insight into
333  * the memory layout of compiled code. Set a breakpoint at the next instruction
334  * in this word, and run until we hit it
335  */
336 static void
337 ficlPrimitiveStepOver(ficlVm *vm)
338 {
339 	ficlWord *word;
340 	ficlWordKind kind;
341 	ficlWord *pStep = ficlSystemLookup(vm->callback.system, "step-break");
342 	FICL_VM_ASSERT(vm, pStep);
343 
344 	word = *vm->ip;
345 	kind = ficlWordClassify(word);
346 
347 	switch (kind) {
348 	case FICL_WORDKIND_COLON:
349 	case FICL_WORDKIND_DOES:
350 		/*
351 		 * assume that the next ficlCell holds an instruction
352 		 * set a breakpoint there and return to the inner interpreter
353 		 */
354 		vm->callback.system->breakpoint.address = vm->ip + 1;
355 		vm->callback.system->breakpoint.oldXT =  vm->ip[1];
356 		vm->ip[1] = pStep;
357 	break;
358 	default:
359 		ficlPrimitiveStepIn(vm);
360 	break;
361 	}
362 }
363 
364 /*
365  * s t e p - b r e a k
366  * Ficl
367  * Handles breakpoints for stepped execution.
368  * Upon entry, breakpoint contains the address and replaced instruction
369  * of the current breakpoint.
370  * Clear the breakpoint
371  * Get a command from the console.
372  * i (step in) - execute the current instruction and set a new breakpoint
373  *    at the IP
374  * o (step over) - execute the current instruction to completion and set
375  *    a new breakpoint at the IP
376  * g (go) - execute the current instruction and exit
377  * q (quit) - abort current word
378  * b (toggle breakpoint)
379  */
380 
381 extern char *ficlDictionaryInstructionNames[];
382 
383 static void
384 ficlPrimitiveStepBreak(ficlVm *vm)
385 {
386 	ficlString command;
387 	ficlWord *word;
388 	ficlWord *pOnStep;
389 	bool debug = true;
390 
391 	if (!vm->restart) {
392 		FICL_VM_ASSERT(vm, vm->callback.system->breakpoint.address);
393 		FICL_VM_ASSERT(vm, vm->callback.system->breakpoint.oldXT);
394 
395 		/*
396 		 * Clear the breakpoint that caused me to run
397 		 * Restore the original instruction at the breakpoint,
398 		 * and restore the IP
399 		 */
400 		vm->ip = (ficlIp)(vm->callback.system->breakpoint.address);
401 		*vm->ip = vm->callback.system->breakpoint.oldXT;
402 
403 		/*
404 		 * If there's an onStep, do it
405 		 */
406 		pOnStep = ficlSystemLookup(vm->callback.system, "on-step");
407 		if (pOnStep)
408 			ficlVmExecuteXT(vm, pOnStep);
409 
410 		/*
411 		 * Print the name of the next instruction
412 		 */
413 		word = vm->callback.system->breakpoint.oldXT;
414 
415 		if ((((ficlInstruction)word) > ficlInstructionInvalid) &&
416 		    (((ficlInstruction)word) < ficlInstructionLast))
417 			sprintf(vm->pad, "next: %s (instruction %ld)\n",
418 			    ficlDictionaryInstructionNames[(long)word],
419 			    (long)word);
420 		else {
421 			sprintf(vm->pad, "next: %s\n", word->name);
422 			if (strcmp(word->name, "interpret") == 0)
423 				debug = false;
424 		}
425 
426 		ficlVmTextOut(vm, vm->pad);
427 		ficlDebugPrompt(debug);
428 	} else {
429 		vm->restart = 0;
430 	}
431 
432 	command = ficlVmGetWord(vm);
433 
434 	switch (command.text[0]) {
435 		case 'i':
436 			ficlPrimitiveStepIn(vm);
437 		break;
438 
439 		case 'o':
440 			ficlPrimitiveStepOver(vm);
441 		break;
442 
443 		case 'g':
444 		break;
445 
446 		case 'l': {
447 			ficlWord *xt;
448 			xt = ficlDictionaryFindEnclosingWord(
449 			    ficlVmGetDictionary(vm), (ficlCell *)(vm->ip));
450 			if (xt) {
451 				ficlStackPushPointer(vm->dataStack, xt);
452 				ficlPrimitiveSeeXT(vm);
453 			} else {
454 				ficlVmTextOut(vm, "sorry - can't do that\n");
455 			}
456 			ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
457 		break;
458 		}
459 
460 		case 'q':
461 			ficlDebugPrompt(false);
462 			ficlVmThrow(vm, FICL_VM_STATUS_ABORT);
463 			break;
464 		case 'x': {
465 			/*
466 			 * Take whatever's left in the TIB and feed it to a
467 			 * subordinate ficlVmExecuteString
468 			 */
469 			int returnValue;
470 			ficlString s;
471 			ficlWord *oldRunningWord = vm->runningWord;
472 
473 			FICL_STRING_SET_POINTER(s,
474 			    vm->tib.text + vm->tib.index);
475 			FICL_STRING_SET_LENGTH(s,
476 			    vm->tib.end - FICL_STRING_GET_POINTER(s));
477 
478 			returnValue = ficlVmExecuteString(vm, s);
479 
480 			if (returnValue == FICL_VM_STATUS_OUT_OF_TEXT) {
481 				returnValue = FICL_VM_STATUS_RESTART;
482 				vm->runningWord = oldRunningWord;
483 				ficlVmTextOut(vm, "\n");
484 			}
485 			if (returnValue == FICL_VM_STATUS_ERROR_EXIT)
486 				ficlDebugPrompt(false);
487 
488 			ficlVmThrow(vm, returnValue);
489 			break;
490 		}
491 
492 		default:
493 			ficlVmTextOut(vm,
494 			    "i -- step In\n"
495 			    "o -- step Over\n"
496 			    "g -- Go (execute to completion)\n"
497 			    "l -- List source code\n"
498 			    "q -- Quit (stop debugging and abort)\n"
499 			    "x -- eXecute the rest of the line "
500 			    "as Ficl words\n");
501 			ficlDebugPrompt(true);
502 			ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
503 		break;
504 	}
505 
506 	ficlDebugPrompt(false);
507 }
508 
509 /*
510  * b y e
511  * TOOLS
512  * Signal the system to shut down - this causes ficlExec to return
513  * VM_USEREXIT. The rest is up to you.
514  */
515 static void
516 ficlPrimitiveBye(ficlVm *vm)
517 {
518 	ficlVmThrow(vm, FICL_VM_STATUS_USER_EXIT);
519 }
520 
521 /*
522  * d i s p l a y S t a c k
523  * TOOLS
524  * Display the parameter stack (code for ".s")
525  */
526 
527 struct stackContext
528 {
529 	ficlVm *vm;
530 	ficlDictionary *dictionary;
531 	int count;
532 };
533 
534 static ficlInteger
535 ficlStackDisplayCallback(void *c, ficlCell *cell)
536 {
537 	struct stackContext *context = (struct stackContext *)c;
538 	char buffer[80];
539 
540 #ifdef _LP64
541 	snprintf(buffer, sizeof (buffer), "[0x%016lx %3d]: %20ld (0x%016lx)\n",
542 	    (unsigned long)cell, context->count++, (long)cell->i,
543 	    (unsigned long)cell->u);
544 #else
545 	snprintf(buffer, sizeof (buffer), "[0x%08x %3d]: %12d (0x%08x)\n",
546 	    (unsigned)cell, context->count++, cell->i, cell->u);
547 #endif
548 
549 	ficlVmTextOut(context->vm, buffer);
550 	return (FICL_TRUE);
551 }
552 
553 void
554 ficlStackDisplay(ficlStack *stack, ficlStackWalkFunction callback,
555     void *context)
556 {
557 	ficlVm *vm = stack->vm;
558 	char buffer[128];
559 	struct stackContext myContext;
560 
561 	FICL_STACK_CHECK(stack, 0, 0);
562 
563 #ifdef _LP64
564 	sprintf(buffer, "[%s stack has %d entries, top at 0x%016lx]\n",
565 	    stack->name, ficlStackDepth(stack), (unsigned long)stack->top);
566 #else
567 	sprintf(buffer, "[%s stack has %d entries, top at 0x%08x]\n",
568 	    stack->name, ficlStackDepth(stack), (unsigned)stack->top);
569 #endif
570 	ficlVmTextOut(vm, buffer);
571 
572 	if (callback == NULL) {
573 		myContext.vm = vm;
574 		myContext.count = 0;
575 		context = &myContext;
576 		callback = ficlStackDisplayCallback;
577 	}
578 	ficlStackWalk(stack, callback, context, FICL_FALSE);
579 
580 #ifdef _LP64
581 	sprintf(buffer, "[%s stack base at 0x%016lx]\n", stack->name,
582 	    (unsigned long)stack->base);
583 #else
584 	sprintf(buffer, "[%s stack base at 0x%08x]\n", stack->name,
585 	    (unsigned)stack->base);
586 #endif
587 	ficlVmTextOut(vm, buffer);
588 }
589 
590 void
591 ficlVmDisplayDataStack(ficlVm *vm)
592 {
593 	ficlStackDisplay(vm->dataStack, NULL, NULL);
594 }
595 
596 static ficlInteger
597 ficlStackDisplaySimpleCallback(void *c, ficlCell *cell)
598 {
599 	struct stackContext *context = (struct stackContext *)c;
600 	char buffer[32];
601 
602 	sprintf(buffer, "%s%ld", context->count ? " " : "", (long)cell->i);
603 	context->count++;
604 	ficlVmTextOut(context->vm, buffer);
605 	return (FICL_TRUE);
606 }
607 
608 void
609 ficlVmDisplayDataStackSimple(ficlVm *vm)
610 {
611 	ficlStack *stack = vm->dataStack;
612 	char buffer[32];
613 	struct stackContext context;
614 
615 	FICL_STACK_CHECK(stack, 0, 0);
616 
617 	sprintf(buffer, "[%d] ", ficlStackDepth(stack));
618 	ficlVmTextOut(vm, buffer);
619 
620 	context.vm = vm;
621 	context.count = 0;
622 	ficlStackWalk(stack, ficlStackDisplaySimpleCallback, &context,
623 	    FICL_TRUE);
624 }
625 
626 static ficlInteger
627 ficlReturnStackDisplayCallback(void *c, ficlCell *cell)
628 {
629 	struct stackContext *context = (struct stackContext *)c;
630 	char buffer[128];
631 
632 #ifdef _LP64
633 	sprintf(buffer, "[0x%016lx %3d] %20ld (0x%016lx)", (unsigned long)cell,
634 	    context->count++, cell->i, cell->u);
635 #else
636 	sprintf(buffer, "[0x%08x %3d] %12d (0x%08x)", (unsigned)cell,
637 	    context->count++, cell->i, cell->u);
638 #endif
639 
640 	/*
641 	 * Attempt to find the word that contains the return
642 	 * stack address (as if it is part of a colon definition).
643 	 * If this works, also print the name of the word.
644 	 */
645 	if (ficlDictionaryIncludes(context->dictionary, cell->p)) {
646 		ficlWord *word;
647 		word = ficlDictionaryFindEnclosingWord(context->dictionary,
648 		    cell->p);
649 		if (word) {
650 			int offset = (ficlCell *)cell->p - &word->param[0];
651 			sprintf(buffer + strlen(buffer), ", %s + %d ",
652 			    word->name, offset);
653 		}
654 	}
655 	strcat(buffer, "\n");
656 	ficlVmTextOut(context->vm, buffer);
657 	return (FICL_TRUE);
658 }
659 
660 void
661 ficlVmDisplayReturnStack(ficlVm *vm)
662 {
663 	struct stackContext context;
664 	context.vm = vm;
665 	context.count = 0;
666 	context.dictionary = ficlVmGetDictionary(vm);
667 	ficlStackDisplay(vm->returnStack, ficlReturnStackDisplayCallback,
668 	    &context);
669 }
670 
671 /*
672  * f o r g e t - w i d
673  */
674 static void
675 ficlPrimitiveForgetWid(ficlVm *vm)
676 {
677 	ficlDictionary *dictionary = ficlVmGetDictionary(vm);
678 	ficlHash *hash;
679 
680 	hash = (ficlHash *)ficlStackPopPointer(vm->dataStack);
681 	ficlHashForget(hash, dictionary->here);
682 }
683 
684 /*
685  * f o r g e t
686  * TOOLS EXT  ( "<spaces>name" -- )
687  * Skip leading space delimiters. Parse name delimited by a space.
688  * Find name, then delete name from the dictionary along with all
689  * words added to the dictionary after name. An ambiguous
690  * condition exists if name cannot be found.
691  *
692  * If the Search-Order word set is present, FORGET searches the
693  * compilation word list. An ambiguous condition exists if the
694  * compilation word list is deleted.
695  */
696 static void
697 ficlPrimitiveForget(ficlVm *vm)
698 {
699 	void *where;
700 	ficlDictionary *dictionary = ficlVmGetDictionary(vm);
701 	ficlHash *hash = dictionary->compilationWordlist;
702 
703 	ficlPrimitiveTick(vm);
704 	where = ((ficlWord *)ficlStackPopPointer(vm->dataStack))->name;
705 	ficlHashForget(hash, where);
706 	dictionary->here = FICL_POINTER_TO_CELL(where);
707 }
708 
709 /*
710  * w o r d s
711  */
712 #define	nCOLWIDTH	8
713 
714 static void
715 ficlPrimitiveWordsBackend(ficlVm *vm, ficlDictionary *dictionary,
716     ficlHash *hash, char *ss)
717 {
718 	ficlWord *wp;
719 	int nChars = 0;
720 	int len;
721 	unsigned i;
722 	int nWords = 0, dWords = 0;
723 	char *cp;
724 	char *pPad;
725 	int columns;
726 
727 	cp = getenv("screen-#cols");
728 	/*
729 	 * using strtol for now. TODO: refactor number conversion from
730 	 * ficlPrimitiveToNumber() and use it instead.
731 	 */
732 	if (cp == NULL)
733 		columns = 80;
734 	else
735 		columns = strtol(cp, NULL, 0);
736 
737 	/*
738 	 * the pad is fixed size area, it's better to allocate
739 	 * dedicated buffer space to deal with custom terminal sizes.
740 	 */
741 	pPad = malloc(columns + 1);
742 	if (pPad == NULL)
743 		ficlVmThrowError(vm, "Error: out of memory");
744 
745 	pager_open();
746 	for (i = 0; i < hash->size; i++) {
747 		for (wp = hash->table[i]; wp != NULL; wp = wp->link, nWords++) {
748 			if (wp->length == 0) /* ignore :noname defs */
749 				continue;
750 
751 			if (ss != NULL && strstr(wp->name, ss) == NULL)
752 				continue;
753 			if (ss != NULL && dWords == 0) {
754 				sprintf(pPad, "        In vocabulary %s\n",
755 				    hash->name ? hash->name : "<unknown>");
756 				pager_output(pPad);
757 			}
758 			dWords++;
759 
760 			/* prevent line wrap due to long words */
761 			if (nChars + wp->length >= columns) {
762 				pPad[nChars++] = '\n';
763 				pPad[nChars] = '\0';
764 				nChars = 0;
765 				if (pager_output(pPad))
766 					goto pager_done;
767 			}
768 
769 			cp = wp->name;
770 			nChars += sprintf(pPad + nChars, "%s", cp);
771 
772 			if (nChars > columns - 10) {
773 				pPad[nChars++] = '\n';
774 				pPad[nChars] = '\0';
775 				nChars = 0;
776 				if (pager_output(pPad))
777 					goto pager_done;
778 			} else {
779 				len = nCOLWIDTH - nChars % nCOLWIDTH;
780 				while (len-- > 0)
781 					pPad[nChars++] = ' ';
782 			}
783 
784 			if (nChars > columns - 10) {
785 				pPad[nChars++] = '\n';
786 				pPad[nChars] = '\0';
787 				nChars = 0;
788 				if (pager_output(pPad))
789 					goto pager_done;
790 			}
791 		}
792 	}
793 
794 	if (nChars > 0) {
795 		pPad[nChars++] = '\n';
796 		pPad[nChars] = '\0';
797 		nChars = 0;
798 		ficlVmTextOut(vm, pPad);
799 	}
800 
801 	if (ss == NULL) {
802 		sprintf(pPad,
803 		    "Dictionary: %d words, %ld cells used of %u total\n",
804 		    nWords, (long)(dictionary->here - dictionary->base),
805 		    dictionary->size);
806 		pager_output(pPad);
807 	}
808 
809 pager_done:
810 	free(pPad);
811 	pager_close();
812 }
813 
814 static void
815 ficlPrimitiveWords(ficlVm *vm)
816 {
817 	ficlDictionary *dictionary = ficlVmGetDictionary(vm);
818 	ficlHash *hash = dictionary->wordlists[dictionary->wordlistCount - 1];
819 	ficlPrimitiveWordsBackend(vm, dictionary, hash, NULL);
820 }
821 
822 void
823 ficlPrimitiveSiftingImpl(ficlVm *vm, char *ss)
824 {
825 	ficlDictionary *dict = ficlVmGetDictionary(vm);
826 	int i;
827 
828 	for (i = 0; i < dict->wordlistCount; i++)
829 		ficlPrimitiveWordsBackend(vm, dict, dict->wordlists[i], ss);
830 }
831 
832 /*
833  * l i s t E n v
834  * Print symbols defined in the environment
835  */
836 static void
837 ficlPrimitiveListEnv(ficlVm *vm)
838 {
839 	ficlDictionary *dictionary = vm->callback.system->environment;
840 	ficlHash *hash = dictionary->forthWordlist;
841 	ficlWord *word;
842 	unsigned i;
843 	int counter = 0;
844 
845 	pager_open();
846 	for (i = 0; i < hash->size; i++) {
847 		for (word = hash->table[i]; word != NULL;
848 		    word = word->link, counter++) {
849 			sprintf(vm->pad, "%s\n", word->name);
850 			if (pager_output(vm->pad))
851 				goto pager_done;
852 		}
853 	}
854 
855 	sprintf(vm->pad, "Environment: %d words, %ld cells used of %u total\n",
856 	    counter, (long)(dictionary->here - dictionary->base),
857 	    dictionary->size);
858 	pager_output(vm->pad);
859 
860 pager_done:
861 	pager_close();
862 }
863 
864 /*
865  * This word lists the parse steps in order
866  */
867 void
868 ficlPrimitiveParseStepList(ficlVm *vm)
869 {
870 	int i;
871 	ficlSystem *system = vm->callback.system;
872 	FICL_VM_ASSERT(vm, system);
873 
874 	ficlVmTextOut(vm, "Parse steps:\n");
875 	ficlVmTextOut(vm, "lookup\n");
876 
877 	for (i = 0; i < FICL_MAX_PARSE_STEPS; i++) {
878 		if (system->parseList[i] != NULL) {
879 			ficlVmTextOut(vm, system->parseList[i]->name);
880 			ficlVmTextOut(vm, "\n");
881 		} else
882 			break;
883 	}
884 }
885 
886 /*
887  * e n v C o n s t a n t
888  * Ficl interface to ficlSystemSetEnvironment and ficlSetEnvD - allow Ficl
889  * code to set environment constants...
890  */
891 static void
892 ficlPrimitiveEnvConstant(ficlVm *vm)
893 {
894 	unsigned value;
895 	FICL_STACK_CHECK(vm->dataStack, 1, 0);
896 
897 	ficlVmGetWordToPad(vm);
898 	value = ficlStackPopUnsigned(vm->dataStack);
899 	ficlDictionarySetConstant(ficlSystemGetEnvironment(vm->callback.system),
900 	    vm->pad, (ficlUnsigned)value);
901 }
902 
903 static void
904 ficlPrimitiveEnv2Constant(ficlVm *vm)
905 {
906 	ficl2Integer value;
907 
908 	FICL_STACK_CHECK(vm->dataStack, 2, 0);
909 
910 	ficlVmGetWordToPad(vm);
911 	value = ficlStackPop2Integer(vm->dataStack);
912 	ficlDictionarySet2Constant(
913 	    ficlSystemGetEnvironment(vm->callback.system), vm->pad, value);
914 }
915 
916 
917 /*
918  * f i c l C o m p i l e T o o l s
919  * Builds wordset for debugger and TOOLS optional word set
920  */
921 void
922 ficlSystemCompileTools(ficlSystem *system)
923 {
924 	ficlDictionary *dictionary = ficlSystemGetDictionary(system);
925 	ficlDictionary *environment = ficlSystemGetEnvironment(system);
926 
927 	FICL_SYSTEM_ASSERT(system, dictionary);
928 	FICL_SYSTEM_ASSERT(system, environment);
929 
930 
931 	/*
932 	 * TOOLS and TOOLS EXT
933 	 */
934 	ficlDictionarySetPrimitive(dictionary, ".s", ficlVmDisplayDataStack,
935 	    FICL_WORD_DEFAULT);
936 	ficlDictionarySetPrimitive(dictionary, ".s-simple",
937 	    ficlVmDisplayDataStackSimple,  FICL_WORD_DEFAULT);
938 	ficlDictionarySetPrimitive(dictionary, "bye", ficlPrimitiveBye,
939 	    FICL_WORD_DEFAULT);
940 	ficlDictionarySetPrimitive(dictionary, "forget", ficlPrimitiveForget,
941 	    FICL_WORD_DEFAULT);
942 	ficlDictionarySetPrimitive(dictionary, "see", ficlPrimitiveSee,
943 	    FICL_WORD_DEFAULT);
944 	ficlDictionarySetPrimitive(dictionary, "words", ficlPrimitiveWords,
945 	    FICL_WORD_DEFAULT);
946 
947 	/*
948 	 * Set TOOLS environment query values
949 	 */
950 	ficlDictionarySetConstant(environment, "tools", FICL_TRUE);
951 	ficlDictionarySetConstant(environment, "tools-ext", FICL_FALSE);
952 
953 	/*
954 	 * Ficl extras
955 	 */
956 	ficlDictionarySetPrimitive(dictionary, "r.s", ficlVmDisplayReturnStack,
957 	    FICL_WORD_DEFAULT);
958 	ficlDictionarySetPrimitive(dictionary, ".env", ficlPrimitiveListEnv,
959 	    FICL_WORD_DEFAULT);
960 	ficlDictionarySetPrimitive(dictionary, "env-constant",
961 	    ficlPrimitiveEnvConstant, FICL_WORD_DEFAULT);
962 	ficlDictionarySetPrimitive(dictionary, "env-2constant",
963 	    ficlPrimitiveEnv2Constant, FICL_WORD_DEFAULT);
964 	ficlDictionarySetPrimitive(dictionary, "debug-xt", ficlPrimitiveDebugXT,
965 	    FICL_WORD_DEFAULT);
966 	ficlDictionarySetPrimitive(dictionary, "parse-order",
967 	    ficlPrimitiveParseStepList, FICL_WORD_DEFAULT);
968 	ficlDictionarySetPrimitive(dictionary, "step-break",
969 	    ficlPrimitiveStepBreak, FICL_WORD_DEFAULT);
970 	ficlDictionarySetPrimitive(dictionary, "forget-wid",
971 	    ficlPrimitiveForgetWid, FICL_WORD_DEFAULT);
972 	ficlDictionarySetPrimitive(dictionary, "see-xt", ficlPrimitiveSeeXT,
973 	    FICL_WORD_DEFAULT);
974 
975 #if FICL_WANT_FLOAT
976 	ficlDictionarySetPrimitive(dictionary, ".hash",
977 	    ficlPrimitiveHashSummary, FICL_WORD_DEFAULT);
978 #endif
979 }
980