xref: /illumos-gate/usr/src/common/ficl/tools.c (revision c0bb4f73)
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
ficlCallbackAssert(ficlCallback * callback,int expression,char * expressionString,char * filename,int line)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 		(void) 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
ficlVmSetBreak(ficlVm * vm,ficlBreakpoint * pBP)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
ficlDebugPrompt(bool debug)107 ficlDebugPrompt(bool debug)
108 {
109 	if (debug)
110 		(void) setenv("prompt", "dbg> ", 1);
111 	else
112 		(void) 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
ficlPrimitiveHashSummary(ficlVm * vm)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 	(void) 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
ficlPrimitiveSeeXT(ficlVm * vm)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 		(void) 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 		(void) 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 		(void) 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 		(void) 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 		(void) 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 		(void) 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
ficlPrimitiveSee(ficlVm * vm)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
ficlPrimitiveDebugXT(ficlVm * vm)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
ficlPrimitiveStepIn(ficlVm * vm)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
ficlPrimitiveStepOver(ficlVm * vm)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
ficlPrimitiveStepBreak(ficlVm * vm)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 			(void) 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 			(void) sprintf(vm->pad, "next: %s (instruction %ld)\n",
418 			    ficlDictionaryInstructionNames[(long)word],
419 			    (long)word);
420 		else {
421 			(void) 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
ficlPrimitiveBye(ficlVm * vm)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
ficlStackDisplayCallback(void * c,ficlCell * cell)535 ficlStackDisplayCallback(void *c, ficlCell *cell)
536 {
537 	struct stackContext *context = (struct stackContext *)c;
538 	char buffer[80];
539 
540 #ifdef _LP64
541 	(void) snprintf(buffer, sizeof (buffer),
542 	    "[0x%016lx %3d]: %20ld (0x%016lx)\n",
543 	    (unsigned long)cell, context->count++, (long)cell->i,
544 	    (unsigned long)cell->u);
545 #else
546 	(void) snprintf(buffer, sizeof (buffer),
547 	    "[0x%08x %3d]: %12d (0x%08x)\n",
548 	    (unsigned)cell, context->count++, cell->i, cell->u);
549 #endif
550 
551 	ficlVmTextOut(context->vm, buffer);
552 	return (FICL_TRUE);
553 }
554 
555 void
ficlStackDisplay(ficlStack * stack,ficlStackWalkFunction callback,void * context)556 ficlStackDisplay(ficlStack *stack, ficlStackWalkFunction callback,
557     void *context)
558 {
559 	ficlVm *vm = stack->vm;
560 	char buffer[128];
561 	struct stackContext myContext;
562 
563 	FICL_STACK_CHECK(stack, 0, 0);
564 
565 #ifdef _LP64
566 	(void) sprintf(buffer, "[%s stack has %d entries, top at 0x%016lx]\n",
567 	    stack->name, ficlStackDepth(stack), (unsigned long)stack->top);
568 #else
569 	(void) sprintf(buffer, "[%s stack has %d entries, top at 0x%08x]\n",
570 	    stack->name, ficlStackDepth(stack), (unsigned)stack->top);
571 #endif
572 	ficlVmTextOut(vm, buffer);
573 
574 	if (callback == NULL) {
575 		myContext.vm = vm;
576 		myContext.count = 0;
577 		context = &myContext;
578 		callback = ficlStackDisplayCallback;
579 	}
580 	ficlStackWalk(stack, callback, context, FICL_FALSE);
581 
582 #ifdef _LP64
583 	(void) sprintf(buffer, "[%s stack base at 0x%016lx]\n", stack->name,
584 	    (unsigned long)stack->base);
585 #else
586 	(void) sprintf(buffer, "[%s stack base at 0x%08x]\n", stack->name,
587 	    (unsigned)stack->base);
588 #endif
589 	ficlVmTextOut(vm, buffer);
590 }
591 
592 void
ficlVmDisplayDataStack(ficlVm * vm)593 ficlVmDisplayDataStack(ficlVm *vm)
594 {
595 	ficlStackDisplay(vm->dataStack, NULL, NULL);
596 }
597 
598 static ficlInteger
ficlStackDisplaySimpleCallback(void * c,ficlCell * cell)599 ficlStackDisplaySimpleCallback(void *c, ficlCell *cell)
600 {
601 	struct stackContext *context = (struct stackContext *)c;
602 	char buffer[32];
603 
604 	(void) sprintf(buffer, "%s%ld", context->count ? " " : "",
605 	    (long)cell->i);
606 	context->count++;
607 	ficlVmTextOut(context->vm, buffer);
608 	return (FICL_TRUE);
609 }
610 
611 void
ficlVmDisplayDataStackSimple(ficlVm * vm)612 ficlVmDisplayDataStackSimple(ficlVm *vm)
613 {
614 	ficlStack *stack = vm->dataStack;
615 	char buffer[32];
616 	struct stackContext context;
617 
618 	FICL_STACK_CHECK(stack, 0, 0);
619 
620 	(void) sprintf(buffer, "[%d] ", ficlStackDepth(stack));
621 	ficlVmTextOut(vm, buffer);
622 
623 	context.vm = vm;
624 	context.count = 0;
625 	ficlStackWalk(stack, ficlStackDisplaySimpleCallback, &context,
626 	    FICL_TRUE);
627 }
628 
629 static ficlInteger
ficlReturnStackDisplayCallback(void * c,ficlCell * cell)630 ficlReturnStackDisplayCallback(void *c, ficlCell *cell)
631 {
632 	struct stackContext *context = (struct stackContext *)c;
633 	char buffer[128];
634 
635 #ifdef _LP64
636 	(void) sprintf(buffer, "[0x%016lx %3d] %20ld (0x%016lx)",
637 	    (unsigned long)cell, context->count++, cell->i, cell->u);
638 #else
639 	(void) sprintf(buffer, "[0x%08x %3d] %12d (0x%08x)", (unsigned)cell,
640 	    context->count++, cell->i, cell->u);
641 #endif
642 
643 	/*
644 	 * Attempt to find the word that contains the return
645 	 * stack address (as if it is part of a colon definition).
646 	 * If this works, also print the name of the word.
647 	 */
648 	if (ficlDictionaryIncludes(context->dictionary, cell->p)) {
649 		ficlWord *word;
650 		word = ficlDictionaryFindEnclosingWord(context->dictionary,
651 		    cell->p);
652 		if (word) {
653 			int offset = (ficlCell *)cell->p - &word->param[0];
654 			(void) sprintf(buffer + strlen(buffer), ", %s + %d ",
655 			    word->name, offset);
656 		}
657 	}
658 	(void) strcat(buffer, "\n");
659 	ficlVmTextOut(context->vm, buffer);
660 	return (FICL_TRUE);
661 }
662 
663 void
ficlVmDisplayReturnStack(ficlVm * vm)664 ficlVmDisplayReturnStack(ficlVm *vm)
665 {
666 	struct stackContext context;
667 	context.vm = vm;
668 	context.count = 0;
669 	context.dictionary = ficlVmGetDictionary(vm);
670 	ficlStackDisplay(vm->returnStack, ficlReturnStackDisplayCallback,
671 	    &context);
672 }
673 
674 /*
675  * f o r g e t - w i d
676  */
677 static void
ficlPrimitiveForgetWid(ficlVm * vm)678 ficlPrimitiveForgetWid(ficlVm *vm)
679 {
680 	ficlDictionary *dictionary = ficlVmGetDictionary(vm);
681 	ficlHash *hash;
682 
683 	hash = (ficlHash *)ficlStackPopPointer(vm->dataStack);
684 	ficlHashForget(hash, dictionary->here);
685 }
686 
687 /*
688  * f o r g e t
689  * TOOLS EXT  ( "<spaces>name" -- )
690  * Skip leading space delimiters. Parse name delimited by a space.
691  * Find name, then delete name from the dictionary along with all
692  * words added to the dictionary after name. An ambiguous
693  * condition exists if name cannot be found.
694  *
695  * If the Search-Order word set is present, FORGET searches the
696  * compilation word list. An ambiguous condition exists if the
697  * compilation word list is deleted.
698  */
699 static void
ficlPrimitiveForget(ficlVm * vm)700 ficlPrimitiveForget(ficlVm *vm)
701 {
702 	void *where;
703 	ficlDictionary *dictionary = ficlVmGetDictionary(vm);
704 	ficlHash *hash = dictionary->compilationWordlist;
705 
706 	ficlPrimitiveTick(vm);
707 	where = ((ficlWord *)ficlStackPopPointer(vm->dataStack))->name;
708 	ficlHashForget(hash, where);
709 	dictionary->here = FICL_POINTER_TO_CELL(where);
710 }
711 
712 /*
713  * w o r d s
714  */
715 #define	nCOLWIDTH	8
716 
717 static void
ficlPrimitiveWordsBackend(ficlVm * vm,ficlDictionary * dictionary,ficlHash * hash,char * ss)718 ficlPrimitiveWordsBackend(ficlVm *vm, ficlDictionary *dictionary,
719     ficlHash *hash, char *ss)
720 {
721 	ficlWord *wp;
722 	int nChars = 0;
723 	int len;
724 	unsigned i;
725 	int nWords = 0, dWords = 0;
726 	char *cp;
727 	char *pPad;
728 	int columns;
729 
730 	cp = getenv("screen-#cols");
731 	/*
732 	 * using strtol for now. TODO: refactor number conversion from
733 	 * ficlPrimitiveToNumber() and use it instead.
734 	 */
735 	if (cp == NULL)
736 		columns = 80;
737 	else
738 		columns = strtol(cp, NULL, 0);
739 
740 	/*
741 	 * the pad is fixed size area, it's better to allocate
742 	 * dedicated buffer space to deal with custom terminal sizes.
743 	 */
744 	pPad = malloc(columns + 1);
745 	if (pPad == NULL)
746 		ficlVmThrowError(vm, "Error: out of memory");
747 
748 	pager_open();
749 	for (i = 0; i < hash->size; i++) {
750 		for (wp = hash->table[i]; wp != NULL; wp = wp->link, nWords++) {
751 			if (wp->length == 0) /* ignore :noname defs */
752 				continue;
753 
754 			if (ss != NULL && strstr(wp->name, ss) == NULL)
755 				continue;
756 			if (ss != NULL && dWords == 0) {
757 				(void) sprintf(pPad,
758 				    "        In vocabulary %s\n",
759 				    hash->name ? hash->name : "<unknown>");
760 				(void) pager_output(pPad);
761 			}
762 			dWords++;
763 
764 			/* prevent line wrap due to long words */
765 			if (nChars + wp->length >= columns) {
766 				pPad[nChars++] = '\n';
767 				pPad[nChars] = '\0';
768 				nChars = 0;
769 				if (pager_output(pPad))
770 					goto pager_done;
771 			}
772 
773 			cp = wp->name;
774 			nChars += sprintf(pPad + nChars, "%s", cp);
775 
776 			if (nChars > columns - 10) {
777 				pPad[nChars++] = '\n';
778 				pPad[nChars] = '\0';
779 				nChars = 0;
780 				if (pager_output(pPad))
781 					goto pager_done;
782 			} else {
783 				len = nCOLWIDTH - nChars % nCOLWIDTH;
784 				while (len-- > 0)
785 					pPad[nChars++] = ' ';
786 			}
787 
788 			if (nChars > columns - 10) {
789 				pPad[nChars++] = '\n';
790 				pPad[nChars] = '\0';
791 				nChars = 0;
792 				if (pager_output(pPad))
793 					goto pager_done;
794 			}
795 		}
796 	}
797 
798 	if (nChars > 0) {
799 		pPad[nChars++] = '\n';
800 		pPad[nChars] = '\0';
801 		nChars = 0;
802 		ficlVmTextOut(vm, pPad);
803 	}
804 
805 	if (ss == NULL) {
806 		(void) sprintf(pPad,
807 		    "Dictionary: %d words, %ld cells used of %u total\n",
808 		    nWords, (long)(dictionary->here - dictionary->base),
809 		    dictionary->size);
810 		(void) pager_output(pPad);
811 	}
812 
813 pager_done:
814 	free(pPad);
815 	pager_close();
816 }
817 
818 static void
ficlPrimitiveWords(ficlVm * vm)819 ficlPrimitiveWords(ficlVm *vm)
820 {
821 	ficlDictionary *dictionary = ficlVmGetDictionary(vm);
822 	ficlHash *hash = dictionary->wordlists[dictionary->wordlistCount - 1];
823 	ficlPrimitiveWordsBackend(vm, dictionary, hash, NULL);
824 }
825 
826 void
ficlPrimitiveSiftingImpl(ficlVm * vm,char * ss)827 ficlPrimitiveSiftingImpl(ficlVm *vm, char *ss)
828 {
829 	ficlDictionary *dict = ficlVmGetDictionary(vm);
830 	int i;
831 
832 	for (i = 0; i < dict->wordlistCount; i++)
833 		ficlPrimitiveWordsBackend(vm, dict, dict->wordlists[i], ss);
834 }
835 
836 /*
837  * l i s t E n v
838  * Print symbols defined in the environment
839  */
840 static void
ficlPrimitiveListEnv(ficlVm * vm)841 ficlPrimitiveListEnv(ficlVm *vm)
842 {
843 	ficlDictionary *dictionary = vm->callback.system->environment;
844 	ficlHash *hash = dictionary->forthWordlist;
845 	ficlWord *word;
846 	unsigned i;
847 	int counter = 0;
848 
849 	pager_open();
850 	for (i = 0; i < hash->size; i++) {
851 		for (word = hash->table[i]; word != NULL;
852 		    word = word->link, counter++) {
853 			(void) sprintf(vm->pad, "%s\n", word->name);
854 			if (pager_output(vm->pad))
855 				goto pager_done;
856 		}
857 	}
858 
859 	(void) sprintf(vm->pad,
860 	    "Environment: %d words, %ld cells used of %u total\n",
861 	    counter, (long)(dictionary->here - dictionary->base),
862 	    dictionary->size);
863 	(void) pager_output(vm->pad);
864 
865 pager_done:
866 	pager_close();
867 }
868 
869 /*
870  * This word lists the parse steps in order
871  */
872 void
ficlPrimitiveParseStepList(ficlVm * vm)873 ficlPrimitiveParseStepList(ficlVm *vm)
874 {
875 	int i;
876 	ficlSystem *system = vm->callback.system;
877 	FICL_VM_ASSERT(vm, system);
878 
879 	ficlVmTextOut(vm, "Parse steps:\n");
880 	ficlVmTextOut(vm, "lookup\n");
881 
882 	for (i = 0; i < FICL_MAX_PARSE_STEPS; i++) {
883 		if (system->parseList[i] != NULL) {
884 			ficlVmTextOut(vm, system->parseList[i]->name);
885 			ficlVmTextOut(vm, "\n");
886 		} else
887 			break;
888 	}
889 }
890 
891 /*
892  * e n v C o n s t a n t
893  * Ficl interface to ficlSystemSetEnvironment and ficlSetEnvD - allow Ficl
894  * code to set environment constants...
895  */
896 static void
ficlPrimitiveEnvConstant(ficlVm * vm)897 ficlPrimitiveEnvConstant(ficlVm *vm)
898 {
899 	unsigned value;
900 	FICL_STACK_CHECK(vm->dataStack, 1, 0);
901 
902 	(void) ficlVmGetWordToPad(vm);
903 	value = ficlStackPopUnsigned(vm->dataStack);
904 	(void) ficlDictionarySetConstant(
905 	    ficlSystemGetEnvironment(vm->callback.system),
906 	    vm->pad, (ficlUnsigned)value);
907 }
908 
909 static void
ficlPrimitiveEnv2Constant(ficlVm * vm)910 ficlPrimitiveEnv2Constant(ficlVm *vm)
911 {
912 	ficl2Integer value;
913 
914 	FICL_STACK_CHECK(vm->dataStack, 2, 0);
915 
916 	(void) ficlVmGetWordToPad(vm);
917 	value = ficlStackPop2Integer(vm->dataStack);
918 	(void) ficlDictionarySet2Constant(
919 	    ficlSystemGetEnvironment(vm->callback.system), vm->pad, value);
920 }
921 
922 
923 /*
924  * f i c l C o m p i l e T o o l s
925  * Builds wordset for debugger and TOOLS optional word set
926  */
927 void
ficlSystemCompileTools(ficlSystem * system)928 ficlSystemCompileTools(ficlSystem *system)
929 {
930 	ficlDictionary *dictionary = ficlSystemGetDictionary(system);
931 	ficlDictionary *environment = ficlSystemGetEnvironment(system);
932 
933 	FICL_SYSTEM_ASSERT(system, dictionary);
934 	FICL_SYSTEM_ASSERT(system, environment);
935 
936 
937 	/*
938 	 * TOOLS and TOOLS EXT
939 	 */
940 	(void) ficlDictionarySetPrimitive(dictionary, ".s",
941 	    ficlVmDisplayDataStack, FICL_WORD_DEFAULT);
942 	(void) ficlDictionarySetPrimitive(dictionary, ".s-simple",
943 	    ficlVmDisplayDataStackSimple,  FICL_WORD_DEFAULT);
944 	(void) ficlDictionarySetPrimitive(dictionary, "bye", ficlPrimitiveBye,
945 	    FICL_WORD_DEFAULT);
946 	(void) ficlDictionarySetPrimitive(dictionary, "forget",
947 	    ficlPrimitiveForget, FICL_WORD_DEFAULT);
948 	(void) ficlDictionarySetPrimitive(dictionary, "see", ficlPrimitiveSee,
949 	    FICL_WORD_DEFAULT);
950 	(void) ficlDictionarySetPrimitive(dictionary, "words",
951 	    ficlPrimitiveWords, FICL_WORD_DEFAULT);
952 
953 	/*
954 	 * Set TOOLS environment query values
955 	 */
956 	(void) ficlDictionarySetConstant(environment, "tools", FICL_TRUE);
957 	(void) ficlDictionarySetConstant(environment, "tools-ext", FICL_FALSE);
958 
959 	/*
960 	 * Ficl extras
961 	 */
962 	(void) ficlDictionarySetPrimitive(dictionary, "r.s",
963 	    ficlVmDisplayReturnStack, FICL_WORD_DEFAULT);
964 	(void) ficlDictionarySetPrimitive(dictionary, ".env",
965 	    ficlPrimitiveListEnv, FICL_WORD_DEFAULT);
966 	(void) ficlDictionarySetPrimitive(dictionary, "env-constant",
967 	    ficlPrimitiveEnvConstant, FICL_WORD_DEFAULT);
968 	(void) ficlDictionarySetPrimitive(dictionary, "env-2constant",
969 	    ficlPrimitiveEnv2Constant, FICL_WORD_DEFAULT);
970 	(void) ficlDictionarySetPrimitive(dictionary, "debug-xt",
971 	    ficlPrimitiveDebugXT, FICL_WORD_DEFAULT);
972 	(void) ficlDictionarySetPrimitive(dictionary, "parse-order",
973 	    ficlPrimitiveParseStepList, FICL_WORD_DEFAULT);
974 	(void) ficlDictionarySetPrimitive(dictionary, "step-break",
975 	    ficlPrimitiveStepBreak, FICL_WORD_DEFAULT);
976 	(void) ficlDictionarySetPrimitive(dictionary, "forget-wid",
977 	    ficlPrimitiveForgetWid, FICL_WORD_DEFAULT);
978 	(void) ficlDictionarySetPrimitive(dictionary, "see-xt",
979 	    ficlPrimitiveSeeXT, FICL_WORD_DEFAULT);
980 
981 #if FICL_WANT_FLOAT
982 	(void) ficlDictionarySetPrimitive(dictionary, ".hash",
983 	    ficlPrimitiveHashSummary, FICL_WORD_DEFAULT);
984 #endif
985 }
986