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