xref: /illumos-gate/usr/src/common/ficl/tools.c (revision c0bb4f73)
1afc2ba1dSToomas Soome /*
2afc2ba1dSToomas Soome  * t o o l s . c
3afc2ba1dSToomas Soome  * Forth Inspired Command Language - programming tools
4afc2ba1dSToomas Soome  * Author: John Sadler (john_sadler@alum.mit.edu)
5afc2ba1dSToomas Soome  * Created: 20 June 2000
6afc2ba1dSToomas Soome  * $Id: tools.c,v 1.12 2010/08/12 13:57:22 asau Exp $
7afc2ba1dSToomas Soome  */
8afc2ba1dSToomas Soome /*
9afc2ba1dSToomas Soome  * Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
10afc2ba1dSToomas Soome  * All rights reserved.
11afc2ba1dSToomas Soome  *
12afc2ba1dSToomas Soome  * Get the latest Ficl release at http://ficl.sourceforge.net
13afc2ba1dSToomas Soome  *
14afc2ba1dSToomas Soome  * I am interested in hearing from anyone who uses Ficl. If you have
15afc2ba1dSToomas Soome  * a problem, a success story, a defect, an enhancement request, or
16afc2ba1dSToomas Soome  * if you would like to contribute to the Ficl release, please
17afc2ba1dSToomas Soome  * contact me by email at the address above.
18afc2ba1dSToomas Soome  *
19afc2ba1dSToomas Soome  * L I C E N S E  and  D I S C L A I M E R
20afc2ba1dSToomas Soome  *
21afc2ba1dSToomas Soome  * Redistribution and use in source and binary forms, with or without
22afc2ba1dSToomas Soome  * modification, are permitted provided that the following conditions
23afc2ba1dSToomas Soome  * are met:
24afc2ba1dSToomas Soome  * 1. Redistributions of source code must retain the above copyright
25afc2ba1dSToomas Soome  *    notice, this list of conditions and the following disclaimer.
26afc2ba1dSToomas Soome  * 2. Redistributions in binary form must reproduce the above copyright
27afc2ba1dSToomas Soome  *    notice, this list of conditions and the following disclaimer in the
28afc2ba1dSToomas Soome  *    documentation and/or other materials provided with the distribution.
29afc2ba1dSToomas Soome  *
30afc2ba1dSToomas Soome  * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
31afc2ba1dSToomas Soome  * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
32afc2ba1dSToomas Soome  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
33afc2ba1dSToomas Soome  * ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
34afc2ba1dSToomas Soome  * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
35afc2ba1dSToomas Soome  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
36afc2ba1dSToomas Soome  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
37afc2ba1dSToomas Soome  * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
38afc2ba1dSToomas Soome  * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
39afc2ba1dSToomas Soome  * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
40afc2ba1dSToomas Soome  * SUCH DAMAGE.
41afc2ba1dSToomas Soome  */
42afc2ba1dSToomas Soome 
43afc2ba1dSToomas Soome /*
44afc2ba1dSToomas Soome  * NOTES:
45afc2ba1dSToomas Soome  * SEE needs information about the addresses of functions that
46afc2ba1dSToomas Soome  * are the CFAs of colon definitions, constants, variables, DOES>
47afc2ba1dSToomas Soome  * words, and so on. It gets this information from a table and supporting
48afc2ba1dSToomas Soome  * functions in words.c.
49afc2ba1dSToomas Soome  * fiColonParen fiDoDoes createParen fiVariableParen fiUserParen fiConstantParen
50afc2ba1dSToomas Soome  *
51afc2ba1dSToomas Soome  * Step and break debugger for Ficl
52afc2ba1dSToomas Soome  * debug  ( xt -- )   Start debugging an xt
53afc2ba1dSToomas Soome  * Set a breakpoint
54afc2ba1dSToomas Soome  * Specify breakpoint default action
55afc2ba1dSToomas Soome  */
56afc2ba1dSToomas Soome 
571fb83a8fSToomas Soome #include <stdbool.h>
58afc2ba1dSToomas Soome #include "ficl.h"
59afc2ba1dSToomas Soome 
60afc2ba1dSToomas Soome extern void exit(int);
61afc2ba1dSToomas Soome 
62afc2ba1dSToomas Soome static void ficlPrimitiveStepIn(ficlVm *vm);
63afc2ba1dSToomas Soome static void ficlPrimitiveStepOver(ficlVm *vm);
64afc2ba1dSToomas Soome static void ficlPrimitiveStepBreak(ficlVm *vm);
65afc2ba1dSToomas Soome 
66afc2ba1dSToomas Soome void
ficlCallbackAssert(ficlCallback * callback,int expression,char * expressionString,char * filename,int line)67afc2ba1dSToomas Soome ficlCallbackAssert(ficlCallback *callback, int expression,
68afc2ba1dSToomas Soome     char *expressionString, char *filename, int line)
69afc2ba1dSToomas Soome {
70afc2ba1dSToomas Soome #if FICL_ROBUST >= 1
71afc2ba1dSToomas Soome 	if (!expression) {
72afc2ba1dSToomas Soome 		static char buffer[256];
73*c0bb4f73SToomas Soome 		(void) sprintf(buffer, "ASSERTION FAILED at %s:%d: \"%s\"\n",
74afc2ba1dSToomas Soome 		    filename, line, expressionString);
75afc2ba1dSToomas Soome 		ficlCallbackTextOut(callback, buffer);
76afc2ba1dSToomas Soome 		exit(-1);
77afc2ba1dSToomas Soome 	}
78afc2ba1dSToomas Soome #else /* FICL_ROBUST >= 1 */
79afc2ba1dSToomas Soome 	FICL_IGNORE(callback);
80afc2ba1dSToomas Soome 	FICL_IGNORE(expression);
81afc2ba1dSToomas Soome 	FICL_IGNORE(expressionString);
82afc2ba1dSToomas Soome 	FICL_IGNORE(filename);
83afc2ba1dSToomas Soome 	FICL_IGNORE(line);
84afc2ba1dSToomas Soome #endif /* FICL_ROBUST >= 1 */
85afc2ba1dSToomas Soome }
86afc2ba1dSToomas Soome 
87afc2ba1dSToomas Soome /*
88afc2ba1dSToomas Soome  * v m S e t B r e a k
89afc2ba1dSToomas Soome  * Set a breakpoint at the current value of IP by
90afc2ba1dSToomas Soome  * storing that address in a BREAKPOINT record
91afc2ba1dSToomas Soome  */
92afc2ba1dSToomas Soome static void
ficlVmSetBreak(ficlVm * vm,ficlBreakpoint * pBP)93afc2ba1dSToomas Soome ficlVmSetBreak(ficlVm *vm, ficlBreakpoint *pBP)
94afc2ba1dSToomas Soome {
95afc2ba1dSToomas Soome 	ficlWord *pStep = ficlSystemLookup(vm->callback.system, "step-break");
96afc2ba1dSToomas Soome 	FICL_VM_ASSERT(vm, pStep);
97afc2ba1dSToomas Soome 
98afc2ba1dSToomas Soome 	pBP->address = vm->ip;
99afc2ba1dSToomas Soome 	pBP->oldXT = *vm->ip;
100afc2ba1dSToomas Soome 	*vm->ip = pStep;
101afc2ba1dSToomas Soome }
102afc2ba1dSToomas Soome 
103afc2ba1dSToomas Soome /*
104afc2ba1dSToomas Soome  * d e b u g P r o m p t
105afc2ba1dSToomas Soome  */
106afc2ba1dSToomas Soome static void
ficlDebugPrompt(bool debug)1071fb83a8fSToomas Soome ficlDebugPrompt(bool debug)
108afc2ba1dSToomas Soome {
109afc2ba1dSToomas Soome 	if (debug)
110*c0bb4f73SToomas Soome 		(void) setenv("prompt", "dbg> ", 1);
111afc2ba1dSToomas Soome 	else
112*c0bb4f73SToomas Soome 		(void) setenv("prompt", "${interpret}", 1);
113afc2ba1dSToomas Soome }
114afc2ba1dSToomas Soome 
115afc2ba1dSToomas Soome #if 0
116afc2ba1dSToomas Soome static int
117afc2ba1dSToomas Soome isPrimitive(ficlWord *word)
118afc2ba1dSToomas Soome {
119afc2ba1dSToomas Soome 	ficlWordKind wk = ficlWordClassify(word);
120afc2ba1dSToomas Soome 	return ((wk != COLON) && (wk != DOES));
121afc2ba1dSToomas Soome }
122afc2ba1dSToomas Soome #endif
123afc2ba1dSToomas Soome 
124afc2ba1dSToomas Soome /*
125afc2ba1dSToomas Soome  * d i c t H a s h S u m m a r y
126afc2ba1dSToomas Soome  * Calculate a figure of merit for the dictionary hash table based
127afc2ba1dSToomas Soome  * on the average search depth for all the words in the dictionary,
128afc2ba1dSToomas Soome  * assuming uniform distribution of target keys. The figure of merit
129afc2ba1dSToomas Soome  * is the ratio of the total search depth for all keys in the table
130afc2ba1dSToomas Soome  * versus a theoretical optimum that would be achieved if the keys
131afc2ba1dSToomas Soome  * were distributed into the table as evenly as possible.
132afc2ba1dSToomas Soome  * The figure would be worse if the hash table used an open
133afc2ba1dSToomas Soome  * addressing scheme (i.e. collisions resolved by searching the
134afc2ba1dSToomas Soome  * table for an empty slot) for a given size table.
135afc2ba1dSToomas Soome  */
136afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
137afc2ba1dSToomas Soome void
ficlPrimitiveHashSummary(ficlVm * vm)138afc2ba1dSToomas Soome ficlPrimitiveHashSummary(ficlVm *vm)
139afc2ba1dSToomas Soome {
140afc2ba1dSToomas Soome 	ficlDictionary *dictionary = ficlVmGetDictionary(vm);
141afc2ba1dSToomas Soome 	ficlHash *pFHash;
142afc2ba1dSToomas Soome 	ficlWord **hash;
143afc2ba1dSToomas Soome 	unsigned size;
144afc2ba1dSToomas Soome 	ficlWord *word;
145afc2ba1dSToomas Soome 	unsigned i;
146afc2ba1dSToomas Soome 	int nMax = 0;
147afc2ba1dSToomas Soome 	int nWords = 0;
148afc2ba1dSToomas Soome 	int nFilled;
149afc2ba1dSToomas Soome 	double avg = 0.0;
150afc2ba1dSToomas Soome 	double best;
151afc2ba1dSToomas Soome 	int nAvg, nRem, nDepth;
152afc2ba1dSToomas Soome 
153afc2ba1dSToomas Soome 	FICL_VM_DICTIONARY_CHECK(vm, dictionary, 0);
154afc2ba1dSToomas Soome 
155afc2ba1dSToomas Soome 	pFHash = dictionary->wordlists[dictionary->wordlistCount - 1];
156afc2ba1dSToomas Soome 	hash = pFHash->table;
157afc2ba1dSToomas Soome 	size = pFHash->size;
158afc2ba1dSToomas Soome 	nFilled = size;
159afc2ba1dSToomas Soome 
160afc2ba1dSToomas Soome 	for (i = 0; i < size; i++) {
161afc2ba1dSToomas Soome 		int n = 0;
162afc2ba1dSToomas Soome 		word = hash[i];
163afc2ba1dSToomas Soome 
164afc2ba1dSToomas Soome 		while (word) {
165afc2ba1dSToomas Soome 			++n;
166afc2ba1dSToomas Soome 			++nWords;
167afc2ba1dSToomas Soome 			word = word->link;
168afc2ba1dSToomas Soome 		}
169afc2ba1dSToomas Soome 
170afc2ba1dSToomas Soome 		avg += (double)(n * (n+1)) / 2.0;
171afc2ba1dSToomas Soome 
172afc2ba1dSToomas Soome 		if (n > nMax)
173afc2ba1dSToomas Soome 			nMax = n;
174afc2ba1dSToomas Soome 		if (n == 0)
175afc2ba1dSToomas Soome 			--nFilled;
176afc2ba1dSToomas Soome 	}
177afc2ba1dSToomas Soome 
178afc2ba1dSToomas Soome 	/* Calc actual avg search depth for this hash */
179afc2ba1dSToomas Soome 	avg = avg / nWords;
180afc2ba1dSToomas Soome 
181afc2ba1dSToomas Soome 	/* Calc best possible performance with this size hash */
182afc2ba1dSToomas Soome 	nAvg = nWords / size;
183afc2ba1dSToomas Soome 	nRem = nWords % size;
184afc2ba1dSToomas Soome 	nDepth = size * (nAvg * (nAvg+1))/2 + (nAvg+1)*nRem;
185afc2ba1dSToomas Soome 	best = (double)nDepth/nWords;
186afc2ba1dSToomas Soome 
187*c0bb4f73SToomas Soome 	(void) sprintf(vm->pad, "%d bins, %2.0f%% filled, Depth: "
188afc2ba1dSToomas Soome 	    "Max=%d, Avg=%2.1f, Best=%2.1f, Score: %2.0f%%\n",
189afc2ba1dSToomas Soome 	    size, (double)nFilled * 100.0 / size, nMax,
190afc2ba1dSToomas Soome 	    avg, best, 100.0 * best / avg);
191afc2ba1dSToomas Soome 
192afc2ba1dSToomas Soome 	ficlVmTextOut(vm, vm->pad);
193afc2ba1dSToomas Soome }
194afc2ba1dSToomas Soome #endif
195afc2ba1dSToomas Soome 
196afc2ba1dSToomas Soome /*
197afc2ba1dSToomas Soome  * Here's the outer part of the decompiler. It's
198afc2ba1dSToomas Soome  * just a big nested conditional that checks the
199afc2ba1dSToomas Soome  * CFA of the word to decompile for each kind of
200afc2ba1dSToomas Soome  * known word-builder code, and tries to do
201afc2ba1dSToomas Soome  * something appropriate. If the CFA is not recognized,
202afc2ba1dSToomas Soome  * just indicate that it is a primitive.
203afc2ba1dSToomas Soome  */
204afc2ba1dSToomas Soome static void
ficlPrimitiveSeeXT(ficlVm * vm)205afc2ba1dSToomas Soome ficlPrimitiveSeeXT(ficlVm *vm)
206afc2ba1dSToomas Soome {
207afc2ba1dSToomas Soome 	ficlWord *word;
208afc2ba1dSToomas Soome 	ficlWordKind kind;
209afc2ba1dSToomas Soome 
210afc2ba1dSToomas Soome 	word = (ficlWord *)ficlStackPopPointer(vm->dataStack);
211afc2ba1dSToomas Soome 	kind = ficlWordClassify(word);
212afc2ba1dSToomas Soome 
213afc2ba1dSToomas Soome 	switch (kind) {
214afc2ba1dSToomas Soome 	case FICL_WORDKIND_COLON:
215*c0bb4f73SToomas Soome 		(void) sprintf(vm->pad, ": %.*s\n", word->length, word->name);
216afc2ba1dSToomas Soome 		ficlVmTextOut(vm, vm->pad);
217afc2ba1dSToomas Soome 		ficlDictionarySee(ficlVmGetDictionary(vm), word,
218afc2ba1dSToomas Soome 		    &(vm->callback));
219afc2ba1dSToomas Soome 	break;
220afc2ba1dSToomas Soome 	case FICL_WORDKIND_DOES:
221afc2ba1dSToomas Soome 		ficlVmTextOut(vm, "does>\n");
222afc2ba1dSToomas Soome 		ficlDictionarySee(ficlVmGetDictionary(vm),
223afc2ba1dSToomas Soome 		    (ficlWord *)word->param->p, &(vm->callback));
224afc2ba1dSToomas Soome 	break;
225afc2ba1dSToomas Soome 	case FICL_WORDKIND_CREATE:
226afc2ba1dSToomas Soome 		ficlVmTextOut(vm, "create\n");
227afc2ba1dSToomas Soome 	break;
228afc2ba1dSToomas Soome 	case FICL_WORDKIND_VARIABLE:
229*c0bb4f73SToomas Soome 		(void) sprintf(vm->pad, "variable = %ld (%#lx)\n",
230afc2ba1dSToomas Soome 		    (long)word->param->i, (long unsigned)word->param->u);
231afc2ba1dSToomas Soome 		ficlVmTextOut(vm, vm->pad);
232afc2ba1dSToomas Soome 	break;
233afc2ba1dSToomas Soome #if FICL_WANT_USER
234afc2ba1dSToomas Soome 	case FICL_WORDKIND_USER:
235*c0bb4f73SToomas Soome 		(void) sprintf(vm->pad, "user variable %ld (%#lx)\n",
236afc2ba1dSToomas Soome 		    (long)word->param->i, (long unsigned)word->param->u);
237afc2ba1dSToomas Soome 		ficlVmTextOut(vm, vm->pad);
238afc2ba1dSToomas Soome 	break;
239afc2ba1dSToomas Soome #endif
240afc2ba1dSToomas Soome 	case FICL_WORDKIND_CONSTANT:
241*c0bb4f73SToomas Soome 		(void) sprintf(vm->pad, "constant = %ld (%#lx)\n",
242afc2ba1dSToomas Soome 		    (long)word->param->i, (long unsigned)word->param->u);
243afc2ba1dSToomas Soome 		ficlVmTextOut(vm, vm->pad);
244afc2ba1dSToomas Soome 	break;
245afc2ba1dSToomas Soome 	case FICL_WORDKIND_2CONSTANT:
246*c0bb4f73SToomas Soome 		(void) sprintf(vm->pad, "constant = %ld %ld (%#lx %#lx)\n",
247afc2ba1dSToomas Soome 		    (long)word->param[1].i, (long)word->param->i,
248afc2ba1dSToomas Soome 		    (long unsigned)word->param[1].u,
249afc2ba1dSToomas Soome 		    (long unsigned)word->param->u);
250afc2ba1dSToomas Soome 		ficlVmTextOut(vm, vm->pad);
251afc2ba1dSToomas Soome 	break;
252afc2ba1dSToomas Soome 
253afc2ba1dSToomas Soome 	default:
254*c0bb4f73SToomas Soome 		(void) sprintf(vm->pad, "%.*s is a primitive\n", word->length,
255afc2ba1dSToomas Soome 		    word->name);
256afc2ba1dSToomas Soome 		ficlVmTextOut(vm, vm->pad);
257afc2ba1dSToomas Soome 	break;
258afc2ba1dSToomas Soome 	}
259afc2ba1dSToomas Soome 
260afc2ba1dSToomas Soome 	if (word->flags & FICL_WORD_IMMEDIATE) {
261afc2ba1dSToomas Soome 		ficlVmTextOut(vm, "immediate\n");
262afc2ba1dSToomas Soome 	}
263afc2ba1dSToomas Soome 
264afc2ba1dSToomas Soome 	if (word->flags & FICL_WORD_COMPILE_ONLY) {
265afc2ba1dSToomas Soome 		ficlVmTextOut(vm, "compile-only\n");
266afc2ba1dSToomas Soome 	}
267afc2ba1dSToomas Soome }
268afc2ba1dSToomas Soome 
269afc2ba1dSToomas Soome static void
ficlPrimitiveSee(ficlVm * vm)270afc2ba1dSToomas Soome ficlPrimitiveSee(ficlVm *vm)
271afc2ba1dSToomas Soome {
272afc2ba1dSToomas Soome 	ficlPrimitiveTick(vm);
273afc2ba1dSToomas Soome 	ficlPrimitiveSeeXT(vm);
274afc2ba1dSToomas Soome }
275afc2ba1dSToomas Soome 
276afc2ba1dSToomas Soome /*
277afc2ba1dSToomas Soome  * f i c l D e b u g X T
278afc2ba1dSToomas Soome  * debug  ( xt -- )
279afc2ba1dSToomas Soome  * Given an xt of a colon definition or a word defined by DOES>, set the
280afc2ba1dSToomas Soome  * VM up to debug the word: push IP, set the xt as the next thing to execute,
281afc2ba1dSToomas Soome  * set a breakpoint at its first instruction, and run to the breakpoint.
282afc2ba1dSToomas Soome  * Note: the semantics of this word are equivalent to "step in"
283afc2ba1dSToomas Soome  */
284afc2ba1dSToomas Soome static void
ficlPrimitiveDebugXT(ficlVm * vm)285afc2ba1dSToomas Soome ficlPrimitiveDebugXT(ficlVm *vm)
286afc2ba1dSToomas Soome {
287afc2ba1dSToomas Soome 	ficlWord *xt = ficlStackPopPointer(vm->dataStack);
288afc2ba1dSToomas Soome 	ficlWordKind wk = ficlWordClassify(xt);
289afc2ba1dSToomas Soome 
290afc2ba1dSToomas Soome 	ficlStackPushPointer(vm->dataStack, xt);
291afc2ba1dSToomas Soome 	ficlPrimitiveSeeXT(vm);
292afc2ba1dSToomas Soome 
293afc2ba1dSToomas Soome 	switch (wk) {
294afc2ba1dSToomas Soome 	case FICL_WORDKIND_COLON:
295afc2ba1dSToomas Soome 	case FICL_WORDKIND_DOES:
296afc2ba1dSToomas Soome 		/*
297afc2ba1dSToomas Soome 		 * Run the colon code and set a breakpoint at the next
298afc2ba1dSToomas Soome 		 * instruction
299afc2ba1dSToomas Soome 		 */
300afc2ba1dSToomas Soome 		ficlVmExecuteWord(vm, xt);
301afc2ba1dSToomas Soome 		ficlVmSetBreak(vm, &(vm->callback.system->breakpoint));
302afc2ba1dSToomas Soome 	break;
303afc2ba1dSToomas Soome 	default:
304afc2ba1dSToomas Soome 		ficlVmExecuteWord(vm, xt);
305afc2ba1dSToomas Soome 	break;
306afc2ba1dSToomas Soome 	}
307afc2ba1dSToomas Soome }
308afc2ba1dSToomas Soome 
309afc2ba1dSToomas Soome /*
310afc2ba1dSToomas Soome  * s t e p I n
311afc2ba1dSToomas Soome  * Ficl
312afc2ba1dSToomas Soome  * Execute the next instruction, stepping into it if it's a colon definition
313afc2ba1dSToomas Soome  * or a does> word. This is the easy kind of step.
314afc2ba1dSToomas Soome  */
315afc2ba1dSToomas Soome static void
ficlPrimitiveStepIn(ficlVm * vm)316afc2ba1dSToomas Soome ficlPrimitiveStepIn(ficlVm *vm)
317afc2ba1dSToomas Soome {
318afc2ba1dSToomas Soome 	/*
319afc2ba1dSToomas Soome 	 * Do one step of the inner loop
320afc2ba1dSToomas Soome 	 */
321afc2ba1dSToomas Soome 	ficlVmExecuteWord(vm, *vm->ip++);
322afc2ba1dSToomas Soome 
323afc2ba1dSToomas Soome 	/*
324afc2ba1dSToomas Soome 	 * Now set a breakpoint at the next instruction
325afc2ba1dSToomas Soome 	 */
326afc2ba1dSToomas Soome 	ficlVmSetBreak(vm, &(vm->callback.system->breakpoint));
327afc2ba1dSToomas Soome }
328afc2ba1dSToomas Soome 
329afc2ba1dSToomas Soome /*
330afc2ba1dSToomas Soome  * s t e p O v e r
331afc2ba1dSToomas Soome  * Ficl
332afc2ba1dSToomas Soome  * Execute the next instruction atomically. This requires some insight into
333afc2ba1dSToomas Soome  * the memory layout of compiled code. Set a breakpoint at the next instruction
334afc2ba1dSToomas Soome  * in this word, and run until we hit it
335afc2ba1dSToomas Soome  */
336afc2ba1dSToomas Soome static void
ficlPrimitiveStepOver(ficlVm * vm)337afc2ba1dSToomas Soome ficlPrimitiveStepOver(ficlVm *vm)
338afc2ba1dSToomas Soome {
339afc2ba1dSToomas Soome 	ficlWord *word;
340afc2ba1dSToomas Soome 	ficlWordKind kind;
341afc2ba1dSToomas Soome 	ficlWord *pStep = ficlSystemLookup(vm->callback.system, "step-break");
342afc2ba1dSToomas Soome 	FICL_VM_ASSERT(vm, pStep);
343afc2ba1dSToomas Soome 
344afc2ba1dSToomas Soome 	word = *vm->ip;
345afc2ba1dSToomas Soome 	kind = ficlWordClassify(word);
346afc2ba1dSToomas Soome 
347afc2ba1dSToomas Soome 	switch (kind) {
348afc2ba1dSToomas Soome 	case FICL_WORDKIND_COLON:
349afc2ba1dSToomas Soome 	case FICL_WORDKIND_DOES:
350afc2ba1dSToomas Soome 		/*
351afc2ba1dSToomas Soome 		 * assume that the next ficlCell holds an instruction
352afc2ba1dSToomas Soome 		 * set a breakpoint there and return to the inner interpreter
353afc2ba1dSToomas Soome 		 */
354afc2ba1dSToomas Soome 		vm->callback.system->breakpoint.address = vm->ip + 1;
355afc2ba1dSToomas Soome 		vm->callback.system->breakpoint.oldXT =  vm->ip[1];
356afc2ba1dSToomas Soome 		vm->ip[1] = pStep;
357afc2ba1dSToomas Soome 	break;
358afc2ba1dSToomas Soome 	default:
359afc2ba1dSToomas Soome 		ficlPrimitiveStepIn(vm);
360afc2ba1dSToomas Soome 	break;
361afc2ba1dSToomas Soome 	}
362afc2ba1dSToomas Soome }
363afc2ba1dSToomas Soome 
364afc2ba1dSToomas Soome /*
365afc2ba1dSToomas Soome  * s t e p - b r e a k
366afc2ba1dSToomas Soome  * Ficl
367afc2ba1dSToomas Soome  * Handles breakpoints for stepped execution.
368afc2ba1dSToomas Soome  * Upon entry, breakpoint contains the address and replaced instruction
369afc2ba1dSToomas Soome  * of the current breakpoint.
370afc2ba1dSToomas Soome  * Clear the breakpoint
371afc2ba1dSToomas Soome  * Get a command from the console.
372afc2ba1dSToomas Soome  * i (step in) - execute the current instruction and set a new breakpoint
373afc2ba1dSToomas Soome  *    at the IP
374afc2ba1dSToomas Soome  * o (step over) - execute the current instruction to completion and set
375afc2ba1dSToomas Soome  *    a new breakpoint at the IP
376afc2ba1dSToomas Soome  * g (go) - execute the current instruction and exit
377afc2ba1dSToomas Soome  * q (quit) - abort current word
378afc2ba1dSToomas Soome  * b (toggle breakpoint)
379afc2ba1dSToomas Soome  */
380afc2ba1dSToomas Soome 
381afc2ba1dSToomas Soome extern char *ficlDictionaryInstructionNames[];
382afc2ba1dSToomas Soome 
383afc2ba1dSToomas Soome static void
ficlPrimitiveStepBreak(ficlVm * vm)384afc2ba1dSToomas Soome ficlPrimitiveStepBreak(ficlVm *vm)
385afc2ba1dSToomas Soome {
386afc2ba1dSToomas Soome 	ficlString command;
387afc2ba1dSToomas Soome 	ficlWord *word;
388afc2ba1dSToomas Soome 	ficlWord *pOnStep;
3891fb83a8fSToomas Soome 	bool debug = true;
390afc2ba1dSToomas Soome 
391afc2ba1dSToomas Soome 	if (!vm->restart) {
392afc2ba1dSToomas Soome 		FICL_VM_ASSERT(vm, vm->callback.system->breakpoint.address);
393afc2ba1dSToomas Soome 		FICL_VM_ASSERT(vm, vm->callback.system->breakpoint.oldXT);
394afc2ba1dSToomas Soome 
395afc2ba1dSToomas Soome 		/*
396afc2ba1dSToomas Soome 		 * Clear the breakpoint that caused me to run
397afc2ba1dSToomas Soome 		 * Restore the original instruction at the breakpoint,
398afc2ba1dSToomas Soome 		 * and restore the IP
399afc2ba1dSToomas Soome 		 */
400afc2ba1dSToomas Soome 		vm->ip = (ficlIp)(vm->callback.system->breakpoint.address);
401afc2ba1dSToomas Soome 		*vm->ip = vm->callback.system->breakpoint.oldXT;
402afc2ba1dSToomas Soome 
403afc2ba1dSToomas Soome 		/*
404afc2ba1dSToomas Soome 		 * If there's an onStep, do it
405afc2ba1dSToomas Soome 		 */
406afc2ba1dSToomas Soome 		pOnStep = ficlSystemLookup(vm->callback.system, "on-step");
407afc2ba1dSToomas Soome 		if (pOnStep)
408*c0bb4f73SToomas Soome 			(void) ficlVmExecuteXT(vm, pOnStep);
409afc2ba1dSToomas Soome 
410afc2ba1dSToomas Soome 		/*
411afc2ba1dSToomas Soome 		 * Print the name of the next instruction
412afc2ba1dSToomas Soome 		 */
413afc2ba1dSToomas Soome 		word = vm->callback.system->breakpoint.oldXT;
414afc2ba1dSToomas Soome 
415afc2ba1dSToomas Soome 		if ((((ficlInstruction)word) > ficlInstructionInvalid) &&
416afc2ba1dSToomas Soome 		    (((ficlInstruction)word) < ficlInstructionLast))
417*c0bb4f73SToomas Soome 			(void) sprintf(vm->pad, "next: %s (instruction %ld)\n",
418afc2ba1dSToomas Soome 			    ficlDictionaryInstructionNames[(long)word],
419afc2ba1dSToomas Soome 			    (long)word);
420afc2ba1dSToomas Soome 		else {
421*c0bb4f73SToomas Soome 			(void) sprintf(vm->pad, "next: %s\n", word->name);
422afc2ba1dSToomas Soome 			if (strcmp(word->name, "interpret") == 0)
4231fb83a8fSToomas Soome 				debug = false;
424afc2ba1dSToomas Soome 		}
425afc2ba1dSToomas Soome 
426afc2ba1dSToomas Soome 		ficlVmTextOut(vm, vm->pad);
4271fb83a8fSToomas Soome 		ficlDebugPrompt(debug);
428afc2ba1dSToomas Soome 	} else {
429afc2ba1dSToomas Soome 		vm->restart = 0;
430afc2ba1dSToomas Soome 	}
431afc2ba1dSToomas Soome 
432afc2ba1dSToomas Soome 	command = ficlVmGetWord(vm);
433afc2ba1dSToomas Soome 
434afc2ba1dSToomas Soome 	switch (command.text[0]) {
435afc2ba1dSToomas Soome 		case 'i':
436afc2ba1dSToomas Soome 			ficlPrimitiveStepIn(vm);
437afc2ba1dSToomas Soome 		break;
438afc2ba1dSToomas Soome 
439afc2ba1dSToomas Soome 		case 'o':
440afc2ba1dSToomas Soome 			ficlPrimitiveStepOver(vm);
441afc2ba1dSToomas Soome 		break;
442afc2ba1dSToomas Soome 
443afc2ba1dSToomas Soome 		case 'g':
444afc2ba1dSToomas Soome 		break;
445afc2ba1dSToomas Soome 
446afc2ba1dSToomas Soome 		case 'l': {
447afc2ba1dSToomas Soome 			ficlWord *xt;
448afc2ba1dSToomas Soome 			xt = ficlDictionaryFindEnclosingWord(
449afc2ba1dSToomas Soome 			    ficlVmGetDictionary(vm), (ficlCell *)(vm->ip));
450afc2ba1dSToomas Soome 			if (xt) {
451afc2ba1dSToomas Soome 				ficlStackPushPointer(vm->dataStack, xt);
452afc2ba1dSToomas Soome 				ficlPrimitiveSeeXT(vm);
453afc2ba1dSToomas Soome 			} else {
454afc2ba1dSToomas Soome 				ficlVmTextOut(vm, "sorry - can't do that\n");
455afc2ba1dSToomas Soome 			}
456afc2ba1dSToomas Soome 			ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
457afc2ba1dSToomas Soome 		break;
458afc2ba1dSToomas Soome 		}
459afc2ba1dSToomas Soome 
460afc2ba1dSToomas Soome 		case 'q':
4611fb83a8fSToomas Soome 			ficlDebugPrompt(false);
462afc2ba1dSToomas Soome 			ficlVmThrow(vm, FICL_VM_STATUS_ABORT);
463afc2ba1dSToomas Soome 			break;
464afc2ba1dSToomas Soome 		case 'x': {
465afc2ba1dSToomas Soome 			/*
466afc2ba1dSToomas Soome 			 * Take whatever's left in the TIB and feed it to a
467afc2ba1dSToomas Soome 			 * subordinate ficlVmExecuteString
468afc2ba1dSToomas Soome 			 */
469afc2ba1dSToomas Soome 			int returnValue;
470afc2ba1dSToomas Soome 			ficlString s;
471afc2ba1dSToomas Soome 			ficlWord *oldRunningWord = vm->runningWord;
472afc2ba1dSToomas Soome 
473afc2ba1dSToomas Soome 			FICL_STRING_SET_POINTER(s,
474afc2ba1dSToomas Soome 			    vm->tib.text + vm->tib.index);
475afc2ba1dSToomas Soome 			FICL_STRING_SET_LENGTH(s,
476afc2ba1dSToomas Soome 			    vm->tib.end - FICL_STRING_GET_POINTER(s));
477afc2ba1dSToomas Soome 
478afc2ba1dSToomas Soome 			returnValue = ficlVmExecuteString(vm, s);
479afc2ba1dSToomas Soome 
480afc2ba1dSToomas Soome 			if (returnValue == FICL_VM_STATUS_OUT_OF_TEXT) {
481afc2ba1dSToomas Soome 				returnValue = FICL_VM_STATUS_RESTART;
482afc2ba1dSToomas Soome 				vm->runningWord = oldRunningWord;
483afc2ba1dSToomas Soome 				ficlVmTextOut(vm, "\n");
484afc2ba1dSToomas Soome 			}
485afc2ba1dSToomas Soome 			if (returnValue == FICL_VM_STATUS_ERROR_EXIT)
4861fb83a8fSToomas Soome 				ficlDebugPrompt(false);
487afc2ba1dSToomas Soome 
488afc2ba1dSToomas Soome 			ficlVmThrow(vm, returnValue);
489afc2ba1dSToomas Soome 			break;
490afc2ba1dSToomas Soome 		}
491afc2ba1dSToomas Soome 
492afc2ba1dSToomas Soome 		default:
493afc2ba1dSToomas Soome 			ficlVmTextOut(vm,
494afc2ba1dSToomas Soome 			    "i -- step In\n"
495afc2ba1dSToomas Soome 			    "o -- step Over\n"
496afc2ba1dSToomas Soome 			    "g -- Go (execute to completion)\n"
497afc2ba1dSToomas Soome 			    "l -- List source code\n"
498afc2ba1dSToomas Soome 			    "q -- Quit (stop debugging and abort)\n"
499afc2ba1dSToomas Soome 			    "x -- eXecute the rest of the line "
500afc2ba1dSToomas Soome 			    "as Ficl words\n");
5011fb83a8fSToomas Soome 			ficlDebugPrompt(true);
502afc2ba1dSToomas Soome 			ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
503afc2ba1dSToomas Soome 		break;
504afc2ba1dSToomas Soome 	}
505afc2ba1dSToomas Soome 
5061fb83a8fSToomas Soome 	ficlDebugPrompt(false);
507afc2ba1dSToomas Soome }
508afc2ba1dSToomas Soome 
509afc2ba1dSToomas Soome /*
510afc2ba1dSToomas Soome  * b y e
511afc2ba1dSToomas Soome  * TOOLS
512afc2ba1dSToomas Soome  * Signal the system to shut down - this causes ficlExec to return
513afc2ba1dSToomas Soome  * VM_USEREXIT. The rest is up to you.
514afc2ba1dSToomas Soome  */
515afc2ba1dSToomas Soome static void
ficlPrimitiveBye(ficlVm * vm)516afc2ba1dSToomas Soome ficlPrimitiveBye(ficlVm *vm)
517afc2ba1dSToomas Soome {
518afc2ba1dSToomas Soome 	ficlVmThrow(vm, FICL_VM_STATUS_USER_EXIT);
519afc2ba1dSToomas Soome }
520afc2ba1dSToomas Soome 
521afc2ba1dSToomas Soome /*
522afc2ba1dSToomas Soome  * d i s p l a y S t a c k
523afc2ba1dSToomas Soome  * TOOLS
524afc2ba1dSToomas Soome  * Display the parameter stack (code for ".s")
525afc2ba1dSToomas Soome  */
526afc2ba1dSToomas Soome 
527afc2ba1dSToomas Soome struct stackContext
528afc2ba1dSToomas Soome {
529afc2ba1dSToomas Soome 	ficlVm *vm;
530afc2ba1dSToomas Soome 	ficlDictionary *dictionary;
531afc2ba1dSToomas Soome 	int count;
532afc2ba1dSToomas Soome };
533afc2ba1dSToomas Soome 
534afc2ba1dSToomas Soome static ficlInteger
ficlStackDisplayCallback(void * c,ficlCell * cell)535afc2ba1dSToomas Soome ficlStackDisplayCallback(void *c, ficlCell *cell)
536afc2ba1dSToomas Soome {
537afc2ba1dSToomas Soome 	struct stackContext *context = (struct stackContext *)c;
538afc2ba1dSToomas Soome 	char buffer[80];
539afc2ba1dSToomas Soome 
540afc2ba1dSToomas Soome #ifdef _LP64
541*c0bb4f73SToomas Soome 	(void) snprintf(buffer, sizeof (buffer),
542*c0bb4f73SToomas Soome 	    "[0x%016lx %3d]: %20ld (0x%016lx)\n",
543afc2ba1dSToomas Soome 	    (unsigned long)cell, context->count++, (long)cell->i,
544afc2ba1dSToomas Soome 	    (unsigned long)cell->u);
545afc2ba1dSToomas Soome #else
546*c0bb4f73SToomas Soome 	(void) snprintf(buffer, sizeof (buffer),
547*c0bb4f73SToomas Soome 	    "[0x%08x %3d]: %12d (0x%08x)\n",
548afc2ba1dSToomas Soome 	    (unsigned)cell, context->count++, cell->i, cell->u);
549afc2ba1dSToomas Soome #endif
550afc2ba1dSToomas Soome 
551afc2ba1dSToomas Soome 	ficlVmTextOut(context->vm, buffer);
552afc2ba1dSToomas Soome 	return (FICL_TRUE);
553afc2ba1dSToomas Soome }
554afc2ba1dSToomas Soome 
555afc2ba1dSToomas Soome void
ficlStackDisplay(ficlStack * stack,ficlStackWalkFunction callback,void * context)556afc2ba1dSToomas Soome ficlStackDisplay(ficlStack *stack, ficlStackWalkFunction callback,
557afc2ba1dSToomas Soome     void *context)
558afc2ba1dSToomas Soome {
559afc2ba1dSToomas Soome 	ficlVm *vm = stack->vm;
560afc2ba1dSToomas Soome 	char buffer[128];
561afc2ba1dSToomas Soome 	struct stackContext myContext;
562afc2ba1dSToomas Soome 
563afc2ba1dSToomas Soome 	FICL_STACK_CHECK(stack, 0, 0);
564afc2ba1dSToomas Soome 
565afc2ba1dSToomas Soome #ifdef _LP64
566*c0bb4f73SToomas Soome 	(void) sprintf(buffer, "[%s stack has %d entries, top at 0x%016lx]\n",
567afc2ba1dSToomas Soome 	    stack->name, ficlStackDepth(stack), (unsigned long)stack->top);
568afc2ba1dSToomas Soome #else
569*c0bb4f73SToomas Soome 	(void) sprintf(buffer, "[%s stack has %d entries, top at 0x%08x]\n",
570afc2ba1dSToomas Soome 	    stack->name, ficlStackDepth(stack), (unsigned)stack->top);
571afc2ba1dSToomas Soome #endif
572afc2ba1dSToomas Soome 	ficlVmTextOut(vm, buffer);
573afc2ba1dSToomas Soome 
574afc2ba1dSToomas Soome 	if (callback == NULL) {
575afc2ba1dSToomas Soome 		myContext.vm = vm;
576afc2ba1dSToomas Soome 		myContext.count = 0;
577afc2ba1dSToomas Soome 		context = &myContext;
578afc2ba1dSToomas Soome 		callback = ficlStackDisplayCallback;
579afc2ba1dSToomas Soome 	}
580afc2ba1dSToomas Soome 	ficlStackWalk(stack, callback, context, FICL_FALSE);
581afc2ba1dSToomas Soome 
582afc2ba1dSToomas Soome #ifdef _LP64
583*c0bb4f73SToomas Soome 	(void) sprintf(buffer, "[%s stack base at 0x%016lx]\n", stack->name,
584afc2ba1dSToomas Soome 	    (unsigned long)stack->base);
585afc2ba1dSToomas Soome #else
586*c0bb4f73SToomas Soome 	(void) sprintf(buffer, "[%s stack base at 0x%08x]\n", stack->name,
587afc2ba1dSToomas Soome 	    (unsigned)stack->base);
588afc2ba1dSToomas Soome #endif
589afc2ba1dSToomas Soome 	ficlVmTextOut(vm, buffer);
590afc2ba1dSToomas Soome }
591afc2ba1dSToomas Soome 
592afc2ba1dSToomas Soome void
ficlVmDisplayDataStack(ficlVm * vm)593afc2ba1dSToomas Soome ficlVmDisplayDataStack(ficlVm *vm)
594afc2ba1dSToomas Soome {
595afc2ba1dSToomas Soome 	ficlStackDisplay(vm->dataStack, NULL, NULL);
596afc2ba1dSToomas Soome }
597afc2ba1dSToomas Soome 
598afc2ba1dSToomas Soome static ficlInteger
ficlStackDisplaySimpleCallback(void * c,ficlCell * cell)599afc2ba1dSToomas Soome ficlStackDisplaySimpleCallback(void *c, ficlCell *cell)
600afc2ba1dSToomas Soome {
601afc2ba1dSToomas Soome 	struct stackContext *context = (struct stackContext *)c;
602afc2ba1dSToomas Soome 	char buffer[32];
603afc2ba1dSToomas Soome 
604*c0bb4f73SToomas Soome 	(void) sprintf(buffer, "%s%ld", context->count ? " " : "",
605*c0bb4f73SToomas Soome 	    (long)cell->i);
606afc2ba1dSToomas Soome 	context->count++;
607afc2ba1dSToomas Soome 	ficlVmTextOut(context->vm, buffer);
608afc2ba1dSToomas Soome 	return (FICL_TRUE);
609afc2ba1dSToomas Soome }
610afc2ba1dSToomas Soome 
611afc2ba1dSToomas Soome void
ficlVmDisplayDataStackSimple(ficlVm * vm)612afc2ba1dSToomas Soome ficlVmDisplayDataStackSimple(ficlVm *vm)
613afc2ba1dSToomas Soome {
614afc2ba1dSToomas Soome 	ficlStack *stack = vm->dataStack;
615afc2ba1dSToomas Soome 	char buffer[32];
616afc2ba1dSToomas Soome 	struct stackContext context;
617afc2ba1dSToomas Soome 
618afc2ba1dSToomas Soome 	FICL_STACK_CHECK(stack, 0, 0);
619afc2ba1dSToomas Soome 
620*c0bb4f73SToomas Soome 	(void) sprintf(buffer, "[%d] ", ficlStackDepth(stack));
621afc2ba1dSToomas Soome 	ficlVmTextOut(vm, buffer);
622afc2ba1dSToomas Soome 
623afc2ba1dSToomas Soome 	context.vm = vm;
624afc2ba1dSToomas Soome 	context.count = 0;
625afc2ba1dSToomas Soome 	ficlStackWalk(stack, ficlStackDisplaySimpleCallback, &context,
626afc2ba1dSToomas Soome 	    FICL_TRUE);
627afc2ba1dSToomas Soome }
628afc2ba1dSToomas Soome 
629afc2ba1dSToomas Soome static ficlInteger
ficlReturnStackDisplayCallback(void * c,ficlCell * cell)630afc2ba1dSToomas Soome ficlReturnStackDisplayCallback(void *c, ficlCell *cell)
631afc2ba1dSToomas Soome {
632afc2ba1dSToomas Soome 	struct stackContext *context = (struct stackContext *)c;
633afc2ba1dSToomas Soome 	char buffer[128];
634afc2ba1dSToomas Soome 
635afc2ba1dSToomas Soome #ifdef _LP64
636*c0bb4f73SToomas Soome 	(void) sprintf(buffer, "[0x%016lx %3d] %20ld (0x%016lx)",
637*c0bb4f73SToomas Soome 	    (unsigned long)cell, context->count++, cell->i, cell->u);
638afc2ba1dSToomas Soome #else
639*c0bb4f73SToomas Soome 	(void) sprintf(buffer, "[0x%08x %3d] %12d (0x%08x)", (unsigned)cell,
640afc2ba1dSToomas Soome 	    context->count++, cell->i, cell->u);
641afc2ba1dSToomas Soome #endif
642afc2ba1dSToomas Soome 
643afc2ba1dSToomas Soome 	/*
644afc2ba1dSToomas Soome 	 * Attempt to find the word that contains the return
645afc2ba1dSToomas Soome 	 * stack address (as if it is part of a colon definition).
646afc2ba1dSToomas Soome 	 * If this works, also print the name of the word.
647afc2ba1dSToomas Soome 	 */
648afc2ba1dSToomas Soome 	if (ficlDictionaryIncludes(context->dictionary, cell->p)) {
649afc2ba1dSToomas Soome 		ficlWord *word;
650afc2ba1dSToomas Soome 		word = ficlDictionaryFindEnclosingWord(context->dictionary,
651afc2ba1dSToomas Soome 		    cell->p);
652afc2ba1dSToomas Soome 		if (word) {
653afc2ba1dSToomas Soome 			int offset = (ficlCell *)cell->p - &word->param[0];
654*c0bb4f73SToomas Soome 			(void) sprintf(buffer + strlen(buffer), ", %s + %d ",
655afc2ba1dSToomas Soome 			    word->name, offset);
656afc2ba1dSToomas Soome 		}
657afc2ba1dSToomas Soome 	}
658*c0bb4f73SToomas Soome 	(void) strcat(buffer, "\n");
659afc2ba1dSToomas Soome 	ficlVmTextOut(context->vm, buffer);
660afc2ba1dSToomas Soome 	return (FICL_TRUE);
661afc2ba1dSToomas Soome }
662afc2ba1dSToomas Soome 
663afc2ba1dSToomas Soome void
ficlVmDisplayReturnStack(ficlVm * vm)664afc2ba1dSToomas Soome ficlVmDisplayReturnStack(ficlVm *vm)
665afc2ba1dSToomas Soome {
666afc2ba1dSToomas Soome 	struct stackContext context;
667afc2ba1dSToomas Soome 	context.vm = vm;
668afc2ba1dSToomas Soome 	context.count = 0;
669afc2ba1dSToomas Soome 	context.dictionary = ficlVmGetDictionary(vm);
670afc2ba1dSToomas Soome 	ficlStackDisplay(vm->returnStack, ficlReturnStackDisplayCallback,
671afc2ba1dSToomas Soome 	    &context);
672afc2ba1dSToomas Soome }
673afc2ba1dSToomas Soome 
674afc2ba1dSToomas Soome /*
675afc2ba1dSToomas Soome  * f o r g e t - w i d
676afc2ba1dSToomas Soome  */
677afc2ba1dSToomas Soome static void
ficlPrimitiveForgetWid(ficlVm * vm)678afc2ba1dSToomas Soome ficlPrimitiveForgetWid(ficlVm *vm)
679afc2ba1dSToomas Soome {
680afc2ba1dSToomas Soome 	ficlDictionary *dictionary = ficlVmGetDictionary(vm);
681afc2ba1dSToomas Soome 	ficlHash *hash;
682afc2ba1dSToomas Soome 
683afc2ba1dSToomas Soome 	hash = (ficlHash *)ficlStackPopPointer(vm->dataStack);
684afc2ba1dSToomas Soome 	ficlHashForget(hash, dictionary->here);
685afc2ba1dSToomas Soome }
686afc2ba1dSToomas Soome 
687afc2ba1dSToomas Soome /*
688afc2ba1dSToomas Soome  * f o r g e t
689afc2ba1dSToomas Soome  * TOOLS EXT  ( "<spaces>name" -- )
690afc2ba1dSToomas Soome  * Skip leading space delimiters. Parse name delimited by a space.
691afc2ba1dSToomas Soome  * Find name, then delete name from the dictionary along with all
692afc2ba1dSToomas Soome  * words added to the dictionary after name. An ambiguous
693afc2ba1dSToomas Soome  * condition exists if name cannot be found.
694afc2ba1dSToomas Soome  *
695afc2ba1dSToomas Soome  * If the Search-Order word set is present, FORGET searches the
696afc2ba1dSToomas Soome  * compilation word list. An ambiguous condition exists if the
697afc2ba1dSToomas Soome  * compilation word list is deleted.
698afc2ba1dSToomas Soome  */
699afc2ba1dSToomas Soome static void
ficlPrimitiveForget(ficlVm * vm)700afc2ba1dSToomas Soome ficlPrimitiveForget(ficlVm *vm)
701afc2ba1dSToomas Soome {
702afc2ba1dSToomas Soome 	void *where;
703afc2ba1dSToomas Soome 	ficlDictionary *dictionary = ficlVmGetDictionary(vm);
704afc2ba1dSToomas Soome 	ficlHash *hash = dictionary->compilationWordlist;
705afc2ba1dSToomas Soome 
706afc2ba1dSToomas Soome 	ficlPrimitiveTick(vm);
707afc2ba1dSToomas Soome 	where = ((ficlWord *)ficlStackPopPointer(vm->dataStack))->name;
708afc2ba1dSToomas Soome 	ficlHashForget(hash, where);
709afc2ba1dSToomas Soome 	dictionary->here = FICL_POINTER_TO_CELL(where);
710afc2ba1dSToomas Soome }
711afc2ba1dSToomas Soome 
712afc2ba1dSToomas Soome /*
713afc2ba1dSToomas Soome  * w o r d s
714afc2ba1dSToomas Soome  */
715afc2ba1dSToomas Soome #define	nCOLWIDTH	8
716afc2ba1dSToomas Soome 
717afc2ba1dSToomas Soome static void
ficlPrimitiveWordsBackend(ficlVm * vm,ficlDictionary * dictionary,ficlHash * hash,char * ss)7188751d36cSAndy Fiddaman ficlPrimitiveWordsBackend(ficlVm *vm, ficlDictionary *dictionary,
7198751d36cSAndy Fiddaman     ficlHash *hash, char *ss)
720afc2ba1dSToomas Soome {
721afc2ba1dSToomas Soome 	ficlWord *wp;
722afc2ba1dSToomas Soome 	int nChars = 0;
723afc2ba1dSToomas Soome 	int len;
724afc2ba1dSToomas Soome 	unsigned i;
7258751d36cSAndy Fiddaman 	int nWords = 0, dWords = 0;
726afc2ba1dSToomas Soome 	char *cp;
727afc2ba1dSToomas Soome 	char *pPad;
728afc2ba1dSToomas Soome 	int columns;
729afc2ba1dSToomas Soome 
7309890ff83SToomas Soome 	cp = getenv("screen-#cols");
731afc2ba1dSToomas Soome 	/*
732afc2ba1dSToomas Soome 	 * using strtol for now. TODO: refactor number conversion from
733afc2ba1dSToomas Soome 	 * ficlPrimitiveToNumber() and use it instead.
734afc2ba1dSToomas Soome 	 */
735afc2ba1dSToomas Soome 	if (cp == NULL)
736afc2ba1dSToomas Soome 		columns = 80;
737afc2ba1dSToomas Soome 	else
738afc2ba1dSToomas Soome 		columns = strtol(cp, NULL, 0);
739afc2ba1dSToomas Soome 
740afc2ba1dSToomas Soome 	/*
741afc2ba1dSToomas Soome 	 * the pad is fixed size area, it's better to allocate
742afc2ba1dSToomas Soome 	 * dedicated buffer space to deal with custom terminal sizes.
743afc2ba1dSToomas Soome 	 */
744afc2ba1dSToomas Soome 	pPad = malloc(columns + 1);
745afc2ba1dSToomas Soome 	if (pPad == NULL)
746afc2ba1dSToomas Soome 		ficlVmThrowError(vm, "Error: out of memory");
747afc2ba1dSToomas Soome 
748afc2ba1dSToomas Soome 	pager_open();
749afc2ba1dSToomas Soome 	for (i = 0; i < hash->size; i++) {
750afc2ba1dSToomas Soome 		for (wp = hash->table[i]; wp != NULL; wp = wp->link, nWords++) {
751afc2ba1dSToomas Soome 			if (wp->length == 0) /* ignore :noname defs */
752afc2ba1dSToomas Soome 				continue;
753afc2ba1dSToomas Soome 
7548751d36cSAndy Fiddaman 			if (ss != NULL && strstr(wp->name, ss) == NULL)
7558751d36cSAndy Fiddaman 				continue;
7568751d36cSAndy Fiddaman 			if (ss != NULL && dWords == 0) {
757*c0bb4f73SToomas Soome 				(void) sprintf(pPad,
758*c0bb4f73SToomas Soome 				    "        In vocabulary %s\n",
7598751d36cSAndy Fiddaman 				    hash->name ? hash->name : "<unknown>");
760*c0bb4f73SToomas Soome 				(void) pager_output(pPad);
7618751d36cSAndy Fiddaman 			}
7628751d36cSAndy Fiddaman 			dWords++;
7638751d36cSAndy Fiddaman 
764afc2ba1dSToomas Soome 			/* prevent line wrap due to long words */
765afc2ba1dSToomas Soome 			if (nChars + wp->length >= columns) {
766afc2ba1dSToomas Soome 				pPad[nChars++] = '\n';
767afc2ba1dSToomas Soome 				pPad[nChars] = '\0';
768afc2ba1dSToomas Soome 				nChars = 0;
769afc2ba1dSToomas Soome 				if (pager_output(pPad))
770afc2ba1dSToomas Soome 					goto pager_done;
771afc2ba1dSToomas Soome 			}
772afc2ba1dSToomas Soome 
773afc2ba1dSToomas Soome 			cp = wp->name;
774afc2ba1dSToomas Soome 			nChars += sprintf(pPad + nChars, "%s", cp);
775afc2ba1dSToomas Soome 
776afc2ba1dSToomas Soome 			if (nChars > columns - 10) {
777afc2ba1dSToomas Soome 				pPad[nChars++] = '\n';
778afc2ba1dSToomas Soome 				pPad[nChars] = '\0';
779afc2ba1dSToomas Soome 				nChars = 0;
780afc2ba1dSToomas Soome 				if (pager_output(pPad))
781afc2ba1dSToomas Soome 					goto pager_done;
782afc2ba1dSToomas Soome 			} else {
783afc2ba1dSToomas Soome 				len = nCOLWIDTH - nChars % nCOLWIDTH;
784afc2ba1dSToomas Soome 				while (len-- > 0)
785afc2ba1dSToomas Soome 					pPad[nChars++] = ' ';
786afc2ba1dSToomas Soome 			}
787afc2ba1dSToomas Soome 
788afc2ba1dSToomas Soome 			if (nChars > columns - 10) {
789afc2ba1dSToomas Soome 				pPad[nChars++] = '\n';
790afc2ba1dSToomas Soome 				pPad[nChars] = '\0';
791afc2ba1dSToomas Soome 				nChars = 0;
792afc2ba1dSToomas Soome 				if (pager_output(pPad))
793afc2ba1dSToomas Soome 					goto pager_done;
794afc2ba1dSToomas Soome 			}
795afc2ba1dSToomas Soome 		}
796afc2ba1dSToomas Soome 	}
797afc2ba1dSToomas Soome 
798afc2ba1dSToomas Soome 	if (nChars > 0) {
799afc2ba1dSToomas Soome 		pPad[nChars++] = '\n';
800afc2ba1dSToomas Soome 		pPad[nChars] = '\0';
801afc2ba1dSToomas Soome 		nChars = 0;
802afc2ba1dSToomas Soome 		ficlVmTextOut(vm, pPad);
803afc2ba1dSToomas Soome 	}
804afc2ba1dSToomas Soome 
805