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
8058751d36cSAndy Fiddaman if (ss == NULL) {
806*c0bb4f73SToomas Soome (void) sprintf(pPad,
8078751d36cSAndy Fiddaman "Dictionary: %d words, %ld cells used of %u total\n",
8088751d36cSAndy Fiddaman nWords, (long)(dictionary->here - dictionary->base),
8098751d36cSAndy Fiddaman dictionary->size);
810*c0bb4f73SToomas Soome (void) pager_output(pPad);
8118751d36cSAndy Fiddaman }
812afc2ba1dSToomas Soome
813afc2ba1dSToomas Soome pager_done:
814afc2ba1dSToomas Soome free(pPad);
815afc2ba1dSToomas Soome pager_close();
816afc2ba1dSToomas Soome }
817afc2ba1dSToomas Soome
8188751d36cSAndy Fiddaman static void
ficlPrimitiveWords(ficlVm * vm)8198751d36cSAndy Fiddaman ficlPrimitiveWords(ficlVm *vm)
8208751d36cSAndy Fiddaman {
8218751d36cSAndy Fiddaman ficlDictionary *dictionary = ficlVmGetDictionary(vm);
8228751d36cSAndy Fiddaman ficlHash *hash = dictionary->wordlists[dictionary->wordlistCount - 1];
8238751d36cSAndy Fiddaman ficlPrimitiveWordsBackend(vm, dictionary, hash, NULL);
8248751d36cSAndy Fiddaman }
8258751d36cSAndy Fiddaman
8268751d36cSAndy Fiddaman void
ficlPrimitiveSiftingImpl(ficlVm * vm,char * ss)8278751d36cSAndy Fiddaman ficlPrimitiveSiftingImpl(ficlVm *vm, char *ss)
8288751d36cSAndy Fiddaman {
8298751d36cSAndy Fiddaman ficlDictionary *dict = ficlVmGetDictionary(vm);
8308751d36cSAndy Fiddaman int i;
8318751d36cSAndy Fiddaman
8328751d36cSAndy Fiddaman for (i = 0; i < dict->wordlistCount; i++)
8338751d36cSAndy Fiddaman ficlPrimitiveWordsBackend(vm, dict, dict->wordlists[i], ss);
8348751d36cSAndy Fiddaman }
8358751d36cSAndy Fiddaman
836afc2ba1dSToomas Soome /*
837afc2ba1dSToomas Soome * l i s t E n v
838afc2ba1dSToomas Soome * Print symbols defined in the environment
839afc2ba1dSToomas Soome */
840afc2ba1dSToomas Soome static void
ficlPrimitiveListEnv(ficlVm * vm)841afc2ba1dSToomas Soome ficlPrimitiveListEnv(ficlVm *vm)
842afc2ba1dSToomas Soome {
843afc2ba1dSToomas Soome ficlDictionary *dictionary = vm->callback.system->environment;
844afc2ba1dSToomas Soome ficlHash *hash = dictionary->forthWordlist;
845afc2ba1dSToomas Soome ficlWord *word;
846afc2ba1dSToomas Soome unsigned i;
847afc2ba1dSToomas Soome int counter = 0;
848afc2ba1dSToomas Soome
849afc2ba1dSToomas Soome pager_open();
850afc2ba1dSToomas Soome for (i = 0; i < hash->size; i++) {
851afc2ba1dSToomas Soome for (word = hash->table[i]; word != NULL;
852afc2ba1dSToomas Soome word = word->link, counter++) {
853*c0bb4f73SToomas Soome (void) sprintf(vm->pad, "%s\n", word->name);
854afc2ba1dSToomas Soome if (pager_output(vm->pad))
855afc2ba1dSToomas Soome goto pager_done;
856afc2ba1dSToomas Soome }
857afc2ba1dSToomas Soome }
858afc2ba1dSToomas Soome
859*c0bb4f73SToomas Soome (void) sprintf(vm->pad,
860*c0bb4f73SToomas Soome "Environment: %d words, %ld cells used of %u total\n",
861afc2ba1dSToomas Soome counter, (long)(dictionary->here - dictionary->base),
862afc2ba1dSToomas Soome dictionary->size);
863*c0bb4f73SToomas Soome (void) pager_output(vm->pad);
864afc2ba1dSToomas Soome
865afc2ba1dSToomas Soome pager_done:
866afc2ba1dSToomas Soome pager_close();
867afc2ba1dSToomas Soome }
868afc2ba1dSToomas Soome
869afc2ba1dSToomas Soome /*
870afc2ba1dSToomas Soome * This word lists the parse steps in order
871afc2ba1dSToomas Soome */
872afc2ba1dSToomas Soome void
ficlPrimitiveParseStepList(ficlVm * vm)873afc2ba1dSToomas Soome ficlPrimitiveParseStepList(ficlVm *vm)
874afc2ba1dSToomas Soome {
875afc2ba1dSToomas Soome int i;
876afc2ba1dSToomas Soome ficlSystem *system = vm->callback.system;
877afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, system);
878afc2ba1dSToomas Soome
879afc2ba1dSToomas Soome ficlVmTextOut(vm, "Parse steps:\n");
880afc2ba1dSToomas Soome ficlVmTextOut(vm, "lookup\n");
881afc2ba1dSToomas Soome
882afc2ba1dSToomas Soome for (i = 0; i < FICL_MAX_PARSE_STEPS; i++) {
883afc2ba1dSToomas Soome if (system->parseList[i] != NULL) {
884afc2ba1dSToomas Soome ficlVmTextOut(vm, system->parseList[i]->name);
885afc2ba1dSToomas Soome ficlVmTextOut(vm, "\n");
886afc2ba1dSToomas Soome } else
887afc2ba1dSToomas Soome break;
888afc2ba1dSToomas Soome }
889afc2ba1dSToomas Soome }
890afc2ba1dSToomas Soome
891afc2ba1dSToomas Soome /*
892afc2ba1dSToomas Soome * e n v C o n s t a n t
893afc2ba1dSToomas Soome * Ficl interface to ficlSystemSetEnvironment and ficlSetEnvD - allow Ficl
894afc2ba1dSToomas Soome * code to set environment constants...
895afc2ba1dSToomas Soome */
896afc2ba1dSToomas Soome static void
ficlPrimitiveEnvConstant(ficlVm * vm)897afc2ba1dSToomas Soome ficlPrimitiveEnvConstant(ficlVm *vm)
898afc2ba1dSToomas Soome {
899afc2ba1dSToomas Soome unsigned value;
900afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0);
901afc2ba1dSToomas Soome
902*c0bb4f73SToomas Soome (void) ficlVmGetWordToPad(vm);
903afc2ba1dSToomas Soome value = ficlStackPopUnsigned(vm->dataStack);
904*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(
905*c0bb4f73SToomas Soome ficlSystemGetEnvironment(vm->callback.system),
906afc2ba1dSToomas Soome vm->pad, (ficlUnsigned)value);
907afc2ba1dSToomas Soome }
908afc2ba1dSToomas Soome
909afc2ba1dSToomas Soome static void
ficlPrimitiveEnv2Constant(ficlVm * vm)910afc2ba1dSToomas Soome ficlPrimitiveEnv2Constant(ficlVm *vm)
911afc2ba1dSToomas Soome {
912afc2ba1dSToomas Soome ficl2Integer value;
913afc2ba1dSToomas Soome
914afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 0);
915afc2ba1dSToomas Soome
916*c0bb4f73SToomas Soome (void) ficlVmGetWordToPad(vm);
917afc2ba1dSToomas Soome value = ficlStackPop2Integer(vm->dataStack);
918*c0bb4f73SToomas Soome (void) ficlDictionarySet2Constant(
919afc2ba1dSToomas Soome ficlSystemGetEnvironment(vm->callback.system), vm->pad, value);
920afc2ba1dSToomas Soome }
921afc2ba1dSToomas Soome
922afc2ba1dSToomas Soome
923afc2ba1dSToomas Soome /*
924afc2ba1dSToomas Soome * f i c l C o m p i l e T o o l s
925afc2ba1dSToomas Soome * Builds wordset for debugger and TOOLS optional word set
926afc2ba1dSToomas Soome */
927afc2ba1dSToomas Soome void
ficlSystemCompileTools(ficlSystem * system)928afc2ba1dSToomas Soome ficlSystemCompileTools(ficlSystem *system)
929afc2ba1dSToomas Soome {
930afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlSystemGetDictionary(system);
931afc2ba1dSToomas Soome ficlDictionary *environment = ficlSystemGetEnvironment(system);
932afc2ba1dSToomas Soome
933afc2ba1dSToomas Soome FICL_SYSTEM_ASSERT(system, dictionary);
934afc2ba1dSToomas Soome FICL_SYSTEM_ASSERT(system, environment);
935afc2ba1dSToomas Soome
936afc2ba1dSToomas Soome
937afc2ba1dSToomas Soome /*
938afc2ba1dSToomas Soome * TOOLS and TOOLS EXT
939afc2ba1dSToomas Soome */
940*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, ".s",
941*c0bb4f73SToomas Soome ficlVmDisplayDataStack, FICL_WORD_DEFAULT);
942*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, ".s-simple",
943afc2ba1dSToomas Soome ficlVmDisplayDataStackSimple, FICL_WORD_DEFAULT);
944*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "bye", ficlPrimitiveBye,
945afc2ba1dSToomas Soome FICL_WORD_DEFAULT);
946*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "forget",
947*c0bb4f73SToomas Soome ficlPrimitiveForget, FICL_WORD_DEFAULT);
948*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "see", ficlPrimitiveSee,
949afc2ba1dSToomas Soome FICL_WORD_DEFAULT);
950*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "words",
951*c0bb4f73SToomas Soome ficlPrimitiveWords, FICL_WORD_DEFAULT);
952afc2ba1dSToomas Soome
953afc2ba1dSToomas Soome /*
954afc2ba1dSToomas Soome * Set TOOLS environment query values
955afc2ba1dSToomas Soome */
956*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "tools", FICL_TRUE);
957*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "tools-ext", FICL_FALSE);
958afc2ba1dSToomas Soome
959afc2ba1dSToomas Soome /*
960afc2ba1dSToomas Soome * Ficl extras
961afc2ba1dSToomas Soome */
962*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "r.s",
963*c0bb4f73SToomas Soome ficlVmDisplayReturnStack, FICL_WORD_DEFAULT);
964*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, ".env",
965*c0bb4f73SToomas Soome ficlPrimitiveListEnv, FICL_WORD_DEFAULT);
966*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "env-constant",
967afc2ba1dSToomas Soome ficlPrimitiveEnvConstant, FICL_WORD_DEFAULT);
968*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "env-2constant",
969afc2ba1dSToomas Soome ficlPrimitiveEnv2Constant, FICL_WORD_DEFAULT);
970*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "debug-xt",
971*c0bb4f73SToomas Soome ficlPrimitiveDebugXT, FICL_WORD_DEFAULT);
972*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "parse-order",
973afc2ba1dSToomas Soome ficlPrimitiveParseStepList, FICL_WORD_DEFAULT);
974*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "step-break",
975afc2ba1dSToomas Soome ficlPrimitiveStepBreak, FICL_WORD_DEFAULT);
976*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "forget-wid",
977afc2ba1dSToomas Soome ficlPrimitiveForgetWid, FICL_WORD_DEFAULT);
978*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "see-xt",
979*c0bb4f73SToomas Soome ficlPrimitiveSeeXT, FICL_WORD_DEFAULT);
980afc2ba1dSToomas Soome
981afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
982*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, ".hash",
983afc2ba1dSToomas Soome ficlPrimitiveHashSummary, FICL_WORD_DEFAULT);
984afc2ba1dSToomas Soome #endif
985afc2ba1dSToomas Soome }
986