1 /*******************************************************************
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.11 2001/12/05 07:21:34 jsadler Exp $
7 *******************************************************************/
9 ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
10 ** All rights reserved.
12 ** Get the latest Ficl release at http://ficl.sourceforge.net
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.
19 ** L I C E N S E and D I S C L A I M E R
21 ** Redistribution and use in source and binary forms, with or without
22 ** modification, are permitted provided that the following conditions
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.
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
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 ** colonParen doDoes createParen variableParen userParen constantParen
51 ** Step and break debugger for Ficl
52 ** debug ( xt -- ) Start debugging an xt
54 ** Specify breakpoint default action
61 #include <stdio.h> /* sprintf */
72 ** nBREAKPOINTS sizes the breakpoint array. One breakpoint (bp 0) is reserved
73 ** for the STEP command. The rest are user programmable.
75 #define nBREAKPOINTS 32
80 /**************************************************************************
82 ** Set a breakpoint at the current value of IP by
83 ** storing that address in a BREAKPOINT record
84 **************************************************************************/
85 static void vmSetBreak(FICL_VM *pVM, FICL_BREAKPOINT *pBP)
87 FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break");
90 pBP->address = pVM->ip;
91 pBP->origXT = *pVM->ip;
96 /**************************************************************************
97 ** d e b u g P r o m p t
98 **************************************************************************/
99 static void debugPrompt(FICL_VM *pVM)
101 vmTextOut(pVM, "dbg> ", 0);
105 /**************************************************************************
106 ** i s A F i c l W o r d
107 ** Vet a candidate pointer carefully to make sure
108 ** it's not some chunk o' inline data...
109 ** It has to have a name, and it has to look
110 ** like it's in the dictionary address range.
111 ** NOTE: this excludes :noname words!
112 **************************************************************************/
113 int isAFiclWord(FICL_DICT *pd, FICL_WORD *pFW)
116 if (!dictIncludes(pd, pFW))
119 if (!dictIncludes(pd, pFW->name))
122 if ((pFW->link != NULL) && !dictIncludes(pd, pFW->link))
125 if ((pFW->nName <= 0) || (pFW->name[pFW->nName] != '\0'))
128 if (strlen(pFW->name) != pFW->nName)
136 static int isPrimitive(FICL_WORD *pFW)
138 WORDKIND wk = ficlWordClassify(pFW);
139 return ((wk != COLON) && (wk != DOES));
144 /**************************************************************************
145 f i n d E n c l o s i n g W o r d
146 ** Given a pointer to something, check to make sure it's an address in the
147 ** dictionary. If so, search backwards until we find something that looks
148 ** like a dictionary header. If successful, return the address of the
149 ** FICL_WORD found. Otherwise return NULL.
150 ** nSEARCH_CELLS sets the maximum neighborhood this func will search before giving up
151 **************************************************************************/
152 #define nSEARCH_CELLS 100
154 static FICL_WORD *findEnclosingWord(FICL_VM *pVM, CELL *cp)
157 FICL_DICT *pd = vmGetDict(pVM);
160 if (!dictIncludes(pd, (void *)cp))
163 for (i = nSEARCH_CELLS; i > 0; --i, --cp)
165 pFW = (FICL_WORD *)(cp + 1 - (sizeof (FICL_WORD) / sizeof (CELL)));
166 if (isAFiclWord(pd, pFW))
174 /**************************************************************************
176 ** TOOLS ( "<spaces>name" -- )
177 ** Display a human-readable representation of the named word's definition.
178 ** The source of the representation (object-code decompilation, source
179 ** block, etc.) and the particular form of the display is implementation
181 **************************************************************************/
183 ** seeColon (for proctologists only)
184 ** Walks a colon definition, decompiling
185 ** on the fly. Knows about primitive control structures.
187 static void seeColon(FICL_VM *pVM, CELL *pc)
191 FICL_DICT *pd = vmGetDict(pVM);
192 FICL_WORD *pSemiParen = ficlLookup(pVM->pSys, "(;)");
195 for (; pc->p != pSemiParen; pc++)
197 FICL_WORD *pFW = (FICL_WORD *)(pc->p);
200 if ((void *)pc == (void *)pVM->ip)
204 cp += sprintf(cp, "%3d ", pc-param0);
206 if (isAFiclWord(pd, pFW))
208 WORDKIND kind = ficlWordClassify(pFW);
215 if (isAFiclWord(pd, c.p))
217 FICL_WORD *pLit = (FICL_WORD *)c.p;
218 sprintf(cp, "%.*s ( %#lx literal )",
219 pLit->nName, pLit->name, c.u);
222 sprintf(cp, "literal %ld (%#lx)", c.i, c.u);
226 FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
227 pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
228 sprintf(cp, "s\" %.*s\"", sp->count, sp->text);
233 FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
234 pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
235 sprintf(cp, "c\" %.*s\"", sp->count, sp->text);
241 sprintf(cp, "if / while (branch %d)", pc+c.i-param0);
243 sprintf(cp, "until (branch %d)", pc+c.i-param0);
248 sprintf(cp, "else (branch %d)", pc+c.i-param0);
250 sprintf(cp, "repeat (branch %d)", pc+c.i-param0);
255 sprintf(cp, "?do (leave %d)", (CELL *)c.p-param0);
259 sprintf(cp, "do (leave %d)", (CELL *)c.p-param0);
263 sprintf(cp, "loop (branch %d)", pc+c.i-param0);
267 sprintf(cp, "+loop (branch %d)", pc+c.i-param0);
270 sprintf(cp, "%.*s", pFW->nName, pFW->name);
275 else /* probably not a word - punt and print value */
277 sprintf(cp, "%ld ( %#lx )", pc->i, pc->u);
280 vmTextOut(pVM, pVM->pad, 1);
283 vmTextOut(pVM, ";", 1);
287 ** Here's the outer part of the decompiler. It's
288 ** just a big nested conditional that checks the
289 ** CFA of the word to decompile for each kind of
290 ** known word-builder code, and tries to do
291 ** something appropriate. If the CFA is not recognized,
292 ** just indicate that it is a primitive.
294 static void seeXT(FICL_VM *pVM)
299 pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
300 kind = ficlWordClassify(pFW);
305 sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name);
306 vmTextOut(pVM, pVM->pad, 1);
307 seeColon(pVM, pFW->param);
311 vmTextOut(pVM, "does>", 1);
312 seeColon(pVM, (CELL *)pFW->param->p);
316 vmTextOut(pVM, "create", 1);
320 sprintf(pVM->pad, "variable = %ld (%#lx)", pFW->param->i, pFW->param->u);
321 vmTextOut(pVM, pVM->pad, 1);
326 sprintf(pVM->pad, "user variable %ld (%#lx)", pFW->param->i, pFW->param->u);
327 vmTextOut(pVM, pVM->pad, 1);
332 sprintf(pVM->pad, "constant = %ld (%#lx)", pFW->param->i, pFW->param->u);
333 vmTextOut(pVM, pVM->pad, 1);
336 sprintf(pVM->pad, "%.*s is a primitive", pFW->nName, pFW->name);
337 vmTextOut(pVM, pVM->pad, 1);
341 if (pFW->flags & FW_IMMEDIATE)
343 vmTextOut(pVM, "immediate", 1);
346 if (pFW->flags & FW_COMPILE)
348 vmTextOut(pVM, "compile-only", 1);
355 static void see(FICL_VM *pVM)
363 /**************************************************************************
364 f i c l D e b u g X T
366 ** Given an xt of a colon definition or a word defined by DOES>, set the
367 ** VM up to debug the word: push IP, set the xt as the next thing to execute,
368 ** set a breakpoint at its first instruction, and run to the breakpoint.
369 ** Note: the semantics of this word are equivalent to "step in"
370 **************************************************************************/
371 void ficlDebugXT(FICL_VM *pVM)
373 FICL_WORD *xt = stackPopPtr(pVM->pStack);
374 WORDKIND wk = ficlWordClassify(xt);
376 stackPushPtr(pVM->pStack, xt);
384 ** Run the colon code and set a breakpoint at the next instruction
387 vmSetBreak(pVM, &(pVM->pSys->bpStep));
399 /**************************************************************************
402 ** Execute the next instruction, stepping into it if it's a colon definition
403 ** or a does> word. This is the easy kind of step.
404 **************************************************************************/
405 void stepIn(FICL_VM *pVM)
408 ** Do one step of the inner loop
415 ** Now set a breakpoint at the next instruction
417 vmSetBreak(pVM, &(pVM->pSys->bpStep));
423 /**************************************************************************
426 ** Execute the next instruction atomically. This requires some insight into
427 ** the memory layout of compiled code. Set a breakpoint at the next instruction
428 ** in this word, and run until we hit it
429 **************************************************************************/
430 void stepOver(FICL_VM *pVM)
434 FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break");
438 kind = ficlWordClassify(pFW);
445 ** assume that the next cell holds an instruction
446 ** set a breakpoint there and return to the inner interp
448 pVM->pSys->bpStep.address = pVM->ip + 1;
449 pVM->pSys->bpStep.origXT = pVM->ip[1];
462 /**************************************************************************
465 ** Handles breakpoints for stepped execution.
466 ** Upon entry, bpStep contains the address and replaced instruction
467 ** of the current breakpoint.
468 ** Clear the breakpoint
469 ** Get a command from the console.
470 ** i (step in) - execute the current instruction and set a new breakpoint
472 ** o (step over) - execute the current instruction to completion and set
473 ** a new breakpoint at the IP
474 ** g (go) - execute the current instruction and exit
475 ** q (quit) - abort current word
476 ** b (toggle breakpoint)
477 **************************************************************************/
478 void stepBreak(FICL_VM *pVM)
486 assert(pVM->pSys->bpStep.address);
487 assert(pVM->pSys->bpStep.origXT);
489 ** Clear the breakpoint that caused me to run
490 ** Restore the original instruction at the breakpoint,
491 ** and restore the IP
493 pVM->ip = (IPTYPE)(pVM->pSys->bpStep.address);
494 *pVM->ip = pVM->pSys->bpStep.origXT;
497 ** If there's an onStep, do it
499 pOnStep = ficlLookup(pVM->pSys, "on-step");
501 ficlExecXT(pVM, pOnStep);
504 ** Print the name of the next instruction
506 pFW = pVM->pSys->bpStep.origXT;
507 sprintf(pVM->pad, "next: %.*s", pFW->nName, pFW->name);
509 if (isPrimitive(pFW))
511 strcat(pVM->pad, " ( primitive )");
515 vmTextOut(pVM, pVM->pad, 1);
525 if (!strincmp(si.cp, "i", si.count))
529 else if (!strincmp(si.cp, "g", si.count))
533 else if (!strincmp(si.cp, "l", si.count))
536 xt = findEnclosingWord(pVM, (CELL *)(pVM->ip));
539 stackPushPtr(pVM->pStack, xt);
544 vmTextOut(pVM, "sorry - can't do that", 1);
546 vmThrow(pVM, VM_RESTART);
548 else if (!strincmp(si.cp, "o", si.count))
552 else if (!strincmp(si.cp, "q", si.count))
554 ficlTextOut(pVM, FICL_PROMPT, 0);
555 vmThrow(pVM, VM_ABORT);
557 else if (!strincmp(si.cp, "x", si.count))
560 ** Take whatever's left in the TIB and feed it to a subordinate ficlExec
563 char *cp = pVM->tib.cp + pVM->tib.index;
564 int count = pVM->tib.end - cp;
565 FICL_WORD *oldRun = pVM->runningWord;
567 ret = ficlExecC(pVM, cp, count);
569 if (ret == VM_OUTOFTEXT)
572 pVM->runningWord = oldRun;
573 vmTextOut(pVM, "", 1);
580 vmTextOut(pVM, "i -- step In", 1);
581 vmTextOut(pVM, "o -- step Over", 1);
582 vmTextOut(pVM, "g -- Go (execute to completion)", 1);
583 vmTextOut(pVM, "l -- List source code", 1);
584 vmTextOut(pVM, "q -- Quit (stop debugging and abort)", 1);
585 vmTextOut(pVM, "x -- eXecute the rest of the line as ficl words", 1);
587 vmThrow(pVM, VM_RESTART);
594 /**************************************************************************
597 ** Signal the system to shut down - this causes ficlExec to return
598 ** VM_USEREXIT. The rest is up to you.
599 **************************************************************************/
600 static void bye(FICL_VM *pVM)
602 vmThrow(pVM, VM_USEREXIT);
607 /**************************************************************************
608 d i s p l a y S t a c k
610 ** Display the parameter stack (code for ".s")
611 **************************************************************************/
612 static void displayPStack(FICL_VM *pVM)
614 FICL_STACK *pStk = pVM->pStack;
615 int d = stackDepth(pStk);
619 vmCheckStack(pVM, 0, 0);
622 vmTextOut(pVM, "(Stack Empty) ", 0);
626 for (i = 0; i < d; i++)
628 vmTextOut(pVM, ltoa((*pCell++).i, pVM->pad, pVM->base), 0);
629 vmTextOut(pVM, " ", 0);
636 static void displayRStack(FICL_VM *pVM)
638 FICL_STACK *pStk = pVM->rStack;
639 int d = stackDepth(pStk);
642 FICL_DICT *dp = vmGetDict(pVM);
644 vmCheckStack(pVM, 0, 0);
647 vmTextOut(pVM, "(Stack Empty) ", 0);
651 for (i = 0; i < d; i++)
655 ** Attempt to find the word that contains the
656 ** stacked address (as if it is part of a colon definition).
657 ** If this works, print the name of the word. Otherwise print
658 ** the value as a number.
660 if (dictIncludes(dp, c.p))
662 FICL_WORD *pFW = findEnclosingWord(pVM, c.p);
665 int offset = (CELL *)c.p - &pFW->param[0];
666 sprintf(pVM->pad, "%s+%d ", pFW->name, offset);
667 vmTextOut(pVM, pVM->pad, 0);
668 continue; /* no need to print the numeric value */
671 vmTextOut(pVM, ltoa(c.i, pVM->pad, pVM->base), 0);
672 vmTextOut(pVM, " ", 0);
680 /**************************************************************************
683 **************************************************************************/
684 static void forgetWid(FICL_VM *pVM)
686 FICL_DICT *pDict = vmGetDict(pVM);
689 pHash = (FICL_HASH *)stackPopPtr(pVM->pStack);
690 hashForget(pHash, pDict->here);
696 /**************************************************************************
698 ** TOOLS EXT ( "<spaces>name" -- )
699 ** Skip leading space delimiters. Parse name delimited by a space.
700 ** Find name, then delete name from the dictionary along with all
701 ** words added to the dictionary after name. An ambiguous
702 ** condition exists if name cannot be found.
704 ** If the Search-Order word set is present, FORGET searches the
705 ** compilation word list. An ambiguous condition exists if the
706 ** compilation word list is deleted.
707 **************************************************************************/
708 static void forget(FICL_VM *pVM)
711 FICL_DICT *pDict = vmGetDict(pVM);
712 FICL_HASH *pHash = pDict->pCompile;
715 where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name;
716 hashForget(pHash, where);
717 pDict->here = PTRtoCELL where;
723 /**************************************************************************
726 **************************************************************************/
728 static void listWords(FICL_VM *pVM)
730 FICL_DICT *dp = vmGetDict(pVM);
731 FICL_HASH *pHash = dp->pSearch[dp->nLists - 1];
739 char *pPad = pVM->pad;
741 for (i = 0; i < pHash->size; i++)
743 for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
745 if (wp->nName == 0) /* ignore :noname defs */
749 nChars += sprintf(pPad + nChars, "%s", cp);
758 vmTextOut(pVM, "--- Press Enter to continue ---",0);
760 vmTextOut(pVM,"\r",0);
762 vmTextOut(pVM, pPad, 1);
766 len = nCOLWIDTH - nChars % nCOLWIDTH;
768 pPad[nChars++] = ' ';
778 vmTextOut(pVM, "--- Press Enter to continue ---",0);
780 vmTextOut(pVM,"\r",0);
782 vmTextOut(pVM, pPad, 1);
791 vmTextOut(pVM, pPad, 1);
794 sprintf(pVM->pad, "Dictionary: %d words, %ld cells used of %u total",
795 nWords, (long) (dp->here - dp->dict), dp->size);
796 vmTextOut(pVM, pVM->pad, 1);
801 /**************************************************************************
803 ** Print symbols defined in the environment
804 **************************************************************************/
805 static void listEnv(FICL_VM *pVM)
807 FICL_DICT *dp = pVM->pSys->envp;
808 FICL_HASH *pHash = dp->pForthWords;
813 for (i = 0; i < pHash->size; i++)
815 for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
817 vmTextOut(pVM, wp->name, 1);
821 sprintf(pVM->pad, "Environment: %d words, %ld cells used of %u total",
822 nWords, (long) (dp->here - dp->dict), dp->size);
823 vmTextOut(pVM, pVM->pad, 1);
828 /**************************************************************************
829 e n v C o n s t a n t
830 ** Ficl interface to ficlSetEnv and ficlSetEnvD - allow ficl code to set
831 ** environment constants...
832 **************************************************************************/
833 static void envConstant(FICL_VM *pVM)
838 vmCheckStack(pVM, 1, 0);
843 ficlSetEnv(pVM->pSys, pVM->pad, (FICL_UNS)value);
847 static void env2Constant(FICL_VM *pVM)
852 vmCheckStack(pVM, 2, 0);
858 ficlSetEnvD(pVM->pSys, pVM->pad, v1, v2);
863 /**************************************************************************
864 f i c l C o m p i l e T o o l s
865 ** Builds wordset for debugger and TOOLS optional word set
866 **************************************************************************/
868 void ficlCompileTools(FICL_SYSTEM *pSys)
870 FICL_DICT *dp = pSys->dp;
874 ** TOOLS and TOOLS EXT
876 dictAppendWord(dp, ".s", displayPStack, FW_DEFAULT);
877 dictAppendWord(dp, "bye", bye, FW_DEFAULT);
878 dictAppendWord(dp, "forget", forget, FW_DEFAULT);
879 dictAppendWord(dp, "see", see, FW_DEFAULT);
880 dictAppendWord(dp, "words", listWords, FW_DEFAULT);
883 ** Set TOOLS environment query values
885 ficlSetEnv(pSys, "tools", FICL_TRUE);
886 ficlSetEnv(pSys, "tools-ext", FICL_FALSE);
891 dictAppendWord(dp, "r.s", displayRStack, FW_DEFAULT); /* guy carver */
892 dictAppendWord(dp, ".env", listEnv, FW_DEFAULT);
893 dictAppendWord(dp, "env-constant",
894 envConstant, FW_DEFAULT);
895 dictAppendWord(dp, "env-2constant",
896 env2Constant, FW_DEFAULT);
897 dictAppendWord(dp, "debug-xt", ficlDebugXT, FW_DEFAULT);
898 dictAppendWord(dp, "parse-order",
901 dictAppendWord(dp, "step-break",stepBreak, FW_DEFAULT);
902 dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT);
903 dictAppendWord(dp, "see-xt", seeXT, FW_DEFAULT);