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