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