176116Sdcs/******************************************************************* 276116Sdcs** t o o l s . c 376116Sdcs** Forth Inspired Command Language - programming tools 476116Sdcs** Author: John Sadler (john_sadler@alum.mit.edu) 576116Sdcs** Created: 20 June 2000 694290Sdcs** $Id: tools.c,v 1.11 2001/12/05 07:21:34 jsadler Exp $ 776116Sdcs*******************************************************************/ 876116Sdcs/* 976116Sdcs** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) 1076116Sdcs** All rights reserved. 1176116Sdcs** 1276116Sdcs** Get the latest Ficl release at http://ficl.sourceforge.net 1376116Sdcs** 1494290Sdcs** I am interested in hearing from anyone who uses ficl. If you have 1594290Sdcs** a problem, a success story, a defect, an enhancement request, or 1694290Sdcs** if you would like to contribute to the ficl release, please 1794290Sdcs** contact me by email at the address above. 1894290Sdcs** 1976116Sdcs** L I C E N S E and D I S C L A I M E R 2076116Sdcs** 2176116Sdcs** Redistribution and use in source and binary forms, with or without 2276116Sdcs** modification, are permitted provided that the following conditions 2376116Sdcs** are met: 2476116Sdcs** 1. Redistributions of source code must retain the above copyright 2576116Sdcs** notice, this list of conditions and the following disclaimer. 2676116Sdcs** 2. Redistributions in binary form must reproduce the above copyright 2776116Sdcs** notice, this list of conditions and the following disclaimer in the 2876116Sdcs** documentation and/or other materials provided with the distribution. 2976116Sdcs** 3076116Sdcs** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 3176116Sdcs** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 3276116Sdcs** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 3376116Sdcs** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 3476116Sdcs** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 3576116Sdcs** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 3676116Sdcs** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 3776116Sdcs** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 3876116Sdcs** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 3976116Sdcs** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 4076116Sdcs** SUCH DAMAGE. 4194290Sdcs*/ 4294290Sdcs 4394290Sdcs/* 4494290Sdcs** NOTES: 4594290Sdcs** SEE needs information about the addresses of functions that 4694290Sdcs** are the CFAs of colon definitions, constants, variables, DOES> 4794290Sdcs** words, and so on. It gets this information from a table and supporting 4894290Sdcs** functions in words.c. 4994290Sdcs** colonParen doDoes createParen variableParen userParen constantParen 5076116Sdcs** 5194290Sdcs** Step and break debugger for Ficl 5294290Sdcs** debug ( xt -- ) Start debugging an xt 5394290Sdcs** Set a breakpoint 5494290Sdcs** Specify breakpoint default action 5576116Sdcs*/ 5676116Sdcs 5776116Sdcs/* $FreeBSD$ */ 5876116Sdcs 5976116Sdcs#ifdef TESTMAIN 6076116Sdcs#include <stdlib.h> 6176116Sdcs#include <stdio.h> /* sprintf */ 6276116Sdcs#include <ctype.h> 6376116Sdcs#else 6476116Sdcs#include <stand.h> 6576116Sdcs#endif 6676116Sdcs#include <string.h> 6776116Sdcs#include "ficl.h" 6876116Sdcs 6976116Sdcs 7076116Sdcs#if 0 7176116Sdcs/* 7276116Sdcs** nBREAKPOINTS sizes the breakpoint array. One breakpoint (bp 0) is reserved 7376116Sdcs** for the STEP command. The rest are user programmable. 7476116Sdcs*/ 7576116Sdcs#define nBREAKPOINTS 32 7694290Sdcs 7776116Sdcs#endif 7876116Sdcs 7976116Sdcs 8094290Sdcs/************************************************************************** 8194290Sdcs v m S e t B r e a k 8294290Sdcs** Set a breakpoint at the current value of IP by 8376116Sdcs** storing that address in a BREAKPOINT record 8494290Sdcs**************************************************************************/ 8594290Sdcsstatic void vmSetBreak(FICL_VM *pVM, FICL_BREAKPOINT *pBP) 8676116Sdcs{ 8794290Sdcs FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break"); 8876116Sdcs assert(pStep); 8994290Sdcs 9076116Sdcs pBP->address = pVM->ip; 9176116Sdcs pBP->origXT = *pVM->ip; 9276116Sdcs *pVM->ip = pStep; 9376116Sdcs} 9476116Sdcs 9576116Sdcs 9694290Sdcs/************************************************************************** 9794290Sdcs** d e b u g P r o m p t 9894290Sdcs**************************************************************************/ 9994290Sdcsstatic void debugPrompt(FICL_VM *pVM) 10094290Sdcs{ 10194290Sdcs vmTextOut(pVM, "dbg> ", 0); 10294290Sdcs} 10394290Sdcs 10494290Sdcs 10594290Sdcs/************************************************************************** 10694290Sdcs** i s A F i c l W o r d 10776116Sdcs** Vet a candidate pointer carefully to make sure 10876116Sdcs** it's not some chunk o' inline data... 10976116Sdcs** It has to have a name, and it has to look 11076116Sdcs** like it's in the dictionary address range. 11176116Sdcs** NOTE: this excludes :noname words! 11294290Sdcs**************************************************************************/ 11394290Sdcsint isAFiclWord(FICL_DICT *pd, FICL_WORD *pFW) 11476116Sdcs{ 11576116Sdcs 11676116Sdcs if (!dictIncludes(pd, pFW)) 11776116Sdcs return 0; 11876116Sdcs 11976116Sdcs if (!dictIncludes(pd, pFW->name)) 12076116Sdcs return 0; 12176116Sdcs 12294290Sdcs if ((pFW->link != NULL) && !dictIncludes(pd, pFW->link)) 12394290Sdcs return 0; 12494290Sdcs 12594290Sdcs if ((pFW->nName <= 0) || (pFW->name[pFW->nName] != '\0')) 12694290Sdcs return 0; 12794290Sdcs 12894290Sdcs if (strlen(pFW->name) != pFW->nName) 12994290Sdcs return 0; 13094290Sdcs 13194290Sdcs return 1; 13276116Sdcs} 13376116Sdcs 13476116Sdcs 13594290Sdcs#if 0 13676116Sdcsstatic int isPrimitive(FICL_WORD *pFW) 13776116Sdcs{ 13876116Sdcs WORDKIND wk = ficlWordClassify(pFW); 13976116Sdcs return ((wk != COLON) && (wk != DOES)); 14076116Sdcs} 14194290Sdcs#endif 14276116Sdcs 14376116Sdcs 14476116Sdcs/************************************************************************** 14594290Sdcs f i n d E n c l o s i n g W o r d 14694290Sdcs** Given a pointer to something, check to make sure it's an address in the 14794290Sdcs** dictionary. If so, search backwards until we find something that looks 14894290Sdcs** like a dictionary header. If successful, return the address of the 14994290Sdcs** FICL_WORD found. Otherwise return NULL. 15094290Sdcs** nSEARCH_CELLS sets the maximum neighborhood this func will search before giving up 15194290Sdcs**************************************************************************/ 15294290Sdcs#define nSEARCH_CELLS 100 15394290Sdcs 15494290Sdcsstatic FICL_WORD *findEnclosingWord(FICL_VM *pVM, CELL *cp) 15594290Sdcs{ 15694290Sdcs FICL_WORD *pFW; 15794290Sdcs FICL_DICT *pd = vmGetDict(pVM); 15894290Sdcs int i; 15994290Sdcs 16094290Sdcs if (!dictIncludes(pd, (void *)cp)) 16194290Sdcs return NULL; 16294290Sdcs 16394290Sdcs for (i = nSEARCH_CELLS; i > 0; --i, --cp) 16494290Sdcs { 16594290Sdcs pFW = (FICL_WORD *)(cp + 1 - (sizeof (FICL_WORD) / sizeof (CELL))); 16694290Sdcs if (isAFiclWord(pd, pFW)) 16794290Sdcs return pFW; 16894290Sdcs } 16994290Sdcs 17094290Sdcs return NULL; 17194290Sdcs} 17294290Sdcs 17394290Sdcs 17494290Sdcs/************************************************************************** 17576116Sdcs s e e 17676116Sdcs** TOOLS ( "<spaces>name" -- ) 17776116Sdcs** Display a human-readable representation of the named word's definition. 17876116Sdcs** The source of the representation (object-code decompilation, source 17976116Sdcs** block, etc.) and the particular form of the display is implementation 18076116Sdcs** defined. 18176116Sdcs**************************************************************************/ 18276116Sdcs/* 18376116Sdcs** seeColon (for proctologists only) 18476116Sdcs** Walks a colon definition, decompiling 18576116Sdcs** on the fly. Knows about primitive control structures. 18676116Sdcs*/ 18776116Sdcsstatic void seeColon(FICL_VM *pVM, CELL *pc) 18876116Sdcs{ 18994290Sdcs char *cp; 19094290Sdcs CELL *param0 = pc; 19194290Sdcs FICL_DICT *pd = vmGetDict(pVM); 19294290Sdcs FICL_WORD *pSemiParen = ficlLookup(pVM->pSys, "(;)"); 19376116Sdcs assert(pSemiParen); 19476116Sdcs 19576116Sdcs for (; pc->p != pSemiParen; pc++) 19676116Sdcs { 19776116Sdcs FICL_WORD *pFW = (FICL_WORD *)(pc->p); 19876116Sdcs 19994290Sdcs cp = pVM->pad; 20094290Sdcs if ((void *)pc == (void *)pVM->ip) 20194290Sdcs *cp++ = '>'; 20294290Sdcs else 20394290Sdcs *cp++ = ' '; 204271135Semaste cp += sprintf(cp, "%3d ", (int)(pc-param0)); 20594290Sdcs 20694290Sdcs if (isAFiclWord(pd, pFW)) 20776116Sdcs { 20876116Sdcs WORDKIND kind = ficlWordClassify(pFW); 20976116Sdcs CELL c; 21076116Sdcs 21176116Sdcs switch (kind) 21276116Sdcs { 21376116Sdcs case LITERAL: 21476116Sdcs c = *++pc; 21594290Sdcs if (isAFiclWord(pd, c.p)) 21676116Sdcs { 21776116Sdcs FICL_WORD *pLit = (FICL_WORD *)c.p; 21894290Sdcs sprintf(cp, "%.*s ( %#lx literal )", 219249223Skientzle pLit->nName, pLit->name, (unsigned long)c.u); 22076116Sdcs } 22176116Sdcs else 222249223Skientzle sprintf(cp, "literal %ld (%#lx)", 223249223Skientzle (long)c.i, (unsigned long)c.u); 22476116Sdcs break; 22576116Sdcs case STRINGLIT: 22676116Sdcs { 22776116Sdcs FICL_STRING *sp = (FICL_STRING *)(void *)++pc; 22876116Sdcs pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1; 22994290Sdcs sprintf(cp, "s\" %.*s\"", sp->count, sp->text); 23076116Sdcs } 23176116Sdcs break; 23294290Sdcs case CSTRINGLIT: 23394290Sdcs { 23494290Sdcs FICL_STRING *sp = (FICL_STRING *)(void *)++pc; 23594290Sdcs pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1; 23694290Sdcs sprintf(cp, "c\" %.*s\"", sp->count, sp->text); 23794290Sdcs } 23894290Sdcs break; 23976116Sdcs case IF: 24076116Sdcs c = *++pc; 24176116Sdcs if (c.i > 0) 242271135Semaste sprintf(cp, "if / while (branch %d)", (int)(pc+c.i-param0)); 24376116Sdcs else 244271135Semaste sprintf(cp, "until (branch %d)", (int)(pc+c.i-param0)); 24594290Sdcs break; 24676116Sdcs case BRANCH: 24776116Sdcs c = *++pc; 248167850Sjkim if (c.i == 0) 249271135Semaste sprintf(cp, "repeat (branch %d)", (int)(pc+c.i-param0)); 250167850Sjkim else if (c.i == 1) 251271135Semaste sprintf(cp, "else (branch %d)", (int)(pc+c.i-param0)); 25276116Sdcs else 253271135Semaste sprintf(cp, "endof (branch %d)", (int)(pc+c.i-param0)); 25476116Sdcs break; 25576116Sdcs 256167850Sjkim case OF: 257167850Sjkim c = *++pc; 258271135Semaste sprintf(cp, "of (branch %d)", (int)(pc+c.i-param0)); 259167850Sjkim break; 260167850Sjkim 26176116Sdcs case QDO: 26276116Sdcs c = *++pc; 263271135Semaste sprintf(cp, "?do (leave %d)", (int)((CELL *)c.p-param0)); 26476116Sdcs break; 26576116Sdcs case DO: 26676116Sdcs c = *++pc; 267271135Semaste sprintf(cp, "do (leave %d)", (int)((CELL *)c.p-param0)); 26876116Sdcs break; 26976116Sdcs case LOOP: 27076116Sdcs c = *++pc; 271271135Semaste sprintf(cp, "loop (branch %d)", (int)(pc+c.i-param0)); 27276116Sdcs break; 27376116Sdcs case PLOOP: 27476116Sdcs c = *++pc; 275271135Semaste sprintf(cp, "+loop (branch %d)", (int)(pc+c.i-param0)); 27676116Sdcs break; 27776116Sdcs default: 27894290Sdcs sprintf(cp, "%.*s", pFW->nName, pFW->name); 27976116Sdcs break; 28076116Sdcs } 28176116Sdcs 28276116Sdcs } 28376116Sdcs else /* probably not a word - punt and print value */ 28476116Sdcs { 285249223Skientzle sprintf(cp, "%ld ( %#lx )", (long)pc->i, (unsigned long)pc->u); 28676116Sdcs } 28794290Sdcs 28894290Sdcs vmTextOut(pVM, pVM->pad, 1); 28976116Sdcs } 29076116Sdcs 29176116Sdcs vmTextOut(pVM, ";", 1); 29276116Sdcs} 29376116Sdcs 29476116Sdcs/* 29576116Sdcs** Here's the outer part of the decompiler. It's 29676116Sdcs** just a big nested conditional that checks the 29776116Sdcs** CFA of the word to decompile for each kind of 29876116Sdcs** known word-builder code, and tries to do 29976116Sdcs** something appropriate. If the CFA is not recognized, 30076116Sdcs** just indicate that it is a primitive. 30176116Sdcs*/ 30276116Sdcsstatic void seeXT(FICL_VM *pVM) 30376116Sdcs{ 30476116Sdcs FICL_WORD *pFW; 30576116Sdcs WORDKIND kind; 30676116Sdcs 30776116Sdcs pFW = (FICL_WORD *)stackPopPtr(pVM->pStack); 30876116Sdcs kind = ficlWordClassify(pFW); 30976116Sdcs 31076116Sdcs switch (kind) 31176116Sdcs { 31276116Sdcs case COLON: 31376116Sdcs sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name); 31476116Sdcs vmTextOut(pVM, pVM->pad, 1); 31576116Sdcs seeColon(pVM, pFW->param); 31676116Sdcs break; 31776116Sdcs 31876116Sdcs case DOES: 31976116Sdcs vmTextOut(pVM, "does>", 1); 32076116Sdcs seeColon(pVM, (CELL *)pFW->param->p); 32176116Sdcs break; 32276116Sdcs 32376116Sdcs case CREATE: 32476116Sdcs vmTextOut(pVM, "create", 1); 32576116Sdcs break; 32676116Sdcs 32776116Sdcs case VARIABLE: 328249223Skientzle sprintf(pVM->pad, "variable = %ld (%#lx)", 329249223Skientzle (long)pFW->param->i, (unsigned long)pFW->param->u); 33076116Sdcs vmTextOut(pVM, pVM->pad, 1); 33176116Sdcs break; 33276116Sdcs 33394290Sdcs#if FICL_WANT_USER 33476116Sdcs case USER: 335249223Skientzle sprintf(pVM->pad, "user variable %ld (%#lx)", 336249223Skientzle (long)pFW->param->i, (unsigned long)pFW->param->u); 33776116Sdcs vmTextOut(pVM, pVM->pad, 1); 33876116Sdcs break; 33994290Sdcs#endif 34076116Sdcs 34176116Sdcs case CONSTANT: 342249223Skientzle sprintf(pVM->pad, "constant = %ld (%#lx)", 343249223Skientzle (long)pFW->param->i, (unsigned long)pFW->param->u); 34476116Sdcs vmTextOut(pVM, pVM->pad, 1); 34576116Sdcs 34676116Sdcs default: 34794290Sdcs sprintf(pVM->pad, "%.*s is a primitive", pFW->nName, pFW->name); 34894290Sdcs vmTextOut(pVM, pVM->pad, 1); 34976116Sdcs break; 35076116Sdcs } 35176116Sdcs 35276116Sdcs if (pFW->flags & FW_IMMEDIATE) 35376116Sdcs { 35476116Sdcs vmTextOut(pVM, "immediate", 1); 35576116Sdcs } 35676116Sdcs 35776116Sdcs if (pFW->flags & FW_COMPILE) 35876116Sdcs { 35976116Sdcs vmTextOut(pVM, "compile-only", 1); 36076116Sdcs } 36176116Sdcs 36276116Sdcs return; 36376116Sdcs} 36476116Sdcs 36576116Sdcs 36676116Sdcsstatic void see(FICL_VM *pVM) 36776116Sdcs{ 36876116Sdcs ficlTick(pVM); 36976116Sdcs seeXT(pVM); 37076116Sdcs return; 37176116Sdcs} 37276116Sdcs 37376116Sdcs 37476116Sdcs/************************************************************************** 37576116Sdcs f i c l D e b u g X T 37676116Sdcs** debug ( xt -- ) 37776116Sdcs** Given an xt of a colon definition or a word defined by DOES>, set the 37876116Sdcs** VM up to debug the word: push IP, set the xt as the next thing to execute, 37976116Sdcs** set a breakpoint at its first instruction, and run to the breakpoint. 38076116Sdcs** Note: the semantics of this word are equivalent to "step in" 38176116Sdcs**************************************************************************/ 38276116Sdcsvoid ficlDebugXT(FICL_VM *pVM) 38376116Sdcs{ 38476116Sdcs FICL_WORD *xt = stackPopPtr(pVM->pStack); 38576116Sdcs WORDKIND wk = ficlWordClassify(xt); 38676116Sdcs 38776116Sdcs stackPushPtr(pVM->pStack, xt); 38876116Sdcs seeXT(pVM); 38976116Sdcs 39076116Sdcs switch (wk) 39176116Sdcs { 39276116Sdcs case COLON: 39376116Sdcs case DOES: 39476116Sdcs /* 39576116Sdcs ** Run the colon code and set a breakpoint at the next instruction 39676116Sdcs */ 39776116Sdcs vmExecute(pVM, xt); 39894290Sdcs vmSetBreak(pVM, &(pVM->pSys->bpStep)); 39976116Sdcs break; 40076116Sdcs 40176116Sdcs default: 40276116Sdcs vmExecute(pVM, xt); 40376116Sdcs break; 40476116Sdcs } 40576116Sdcs 40676116Sdcs return; 40776116Sdcs} 40876116Sdcs 40976116Sdcs 41076116Sdcs/************************************************************************** 41176116Sdcs s t e p I n 41276116Sdcs** FICL 41376116Sdcs** Execute the next instruction, stepping into it if it's a colon definition 41476116Sdcs** or a does> word. This is the easy kind of step. 41576116Sdcs**************************************************************************/ 41676116Sdcsvoid stepIn(FICL_VM *pVM) 41776116Sdcs{ 41876116Sdcs /* 41976116Sdcs ** Do one step of the inner loop 42076116Sdcs */ 42176116Sdcs { 42276116Sdcs M_VM_STEP(pVM) 42376116Sdcs } 42476116Sdcs 42576116Sdcs /* 42676116Sdcs ** Now set a breakpoint at the next instruction 42776116Sdcs */ 42894290Sdcs vmSetBreak(pVM, &(pVM->pSys->bpStep)); 42976116Sdcs 43076116Sdcs return; 43176116Sdcs} 43276116Sdcs 43376116Sdcs 43476116Sdcs/************************************************************************** 43576116Sdcs s t e p O v e r 43676116Sdcs** FICL 43776116Sdcs** Execute the next instruction atomically. This requires some insight into 43876116Sdcs** the memory layout of compiled code. Set a breakpoint at the next instruction 43976116Sdcs** in this word, and run until we hit it 44076116Sdcs**************************************************************************/ 44176116Sdcsvoid stepOver(FICL_VM *pVM) 44276116Sdcs{ 44376116Sdcs FICL_WORD *pFW; 44476116Sdcs WORDKIND kind; 44594290Sdcs FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break"); 44676116Sdcs assert(pStep); 44776116Sdcs 44876116Sdcs pFW = *pVM->ip; 44976116Sdcs kind = ficlWordClassify(pFW); 45076116Sdcs 45176116Sdcs switch (kind) 45276116Sdcs { 45376116Sdcs case COLON: 45476116Sdcs case DOES: 45576116Sdcs /* 45676116Sdcs ** assume that the next cell holds an instruction 45776116Sdcs ** set a breakpoint there and return to the inner interp 45876116Sdcs */ 45994290Sdcs pVM->pSys->bpStep.address = pVM->ip + 1; 46094290Sdcs pVM->pSys->bpStep.origXT = pVM->ip[1]; 46176116Sdcs pVM->ip[1] = pStep; 46276116Sdcs break; 46376116Sdcs 46476116Sdcs default: 46576116Sdcs stepIn(pVM); 46676116Sdcs break; 46776116Sdcs } 46876116Sdcs 46976116Sdcs return; 47076116Sdcs} 47176116Sdcs 47276116Sdcs 47376116Sdcs/************************************************************************** 47476116Sdcs s t e p - b r e a k 47576116Sdcs** FICL 47676116Sdcs** Handles breakpoints for stepped execution. 47776116Sdcs** Upon entry, bpStep contains the address and replaced instruction 47876116Sdcs** of the current breakpoint. 47976116Sdcs** Clear the breakpoint 48076116Sdcs** Get a command from the console. 48176116Sdcs** i (step in) - execute the current instruction and set a new breakpoint 48276116Sdcs** at the IP 48376116Sdcs** o (step over) - execute the current instruction to completion and set 48476116Sdcs** a new breakpoint at the IP 48576116Sdcs** g (go) - execute the current instruction and exit 48676116Sdcs** q (quit) - abort current word 48776116Sdcs** b (toggle breakpoint) 48876116Sdcs**************************************************************************/ 48976116Sdcsvoid stepBreak(FICL_VM *pVM) 49076116Sdcs{ 49176116Sdcs STRINGINFO si; 49276116Sdcs FICL_WORD *pFW; 49376116Sdcs FICL_WORD *pOnStep; 49476116Sdcs 49576116Sdcs if (!pVM->fRestart) 49676116Sdcs { 49794290Sdcs assert(pVM->pSys->bpStep.address); 49894290Sdcs assert(pVM->pSys->bpStep.origXT); 49976116Sdcs /* 50076116Sdcs ** Clear the breakpoint that caused me to run 50176116Sdcs ** Restore the original instruction at the breakpoint, 50276116Sdcs ** and restore the IP 50376116Sdcs */ 50494290Sdcs pVM->ip = (IPTYPE)(pVM->pSys->bpStep.address); 50594290Sdcs *pVM->ip = pVM->pSys->bpStep.origXT; 50676116Sdcs 50776116Sdcs /* 50876116Sdcs ** If there's an onStep, do it 50976116Sdcs */ 51094290Sdcs pOnStep = ficlLookup(pVM->pSys, "on-step"); 51176116Sdcs if (pOnStep) 51276116Sdcs ficlExecXT(pVM, pOnStep); 51376116Sdcs 51476116Sdcs /* 51576116Sdcs ** Print the name of the next instruction 51676116Sdcs */ 51794290Sdcs pFW = pVM->pSys->bpStep.origXT; 51876116Sdcs sprintf(pVM->pad, "next: %.*s", pFW->nName, pFW->name); 51994290Sdcs#if 0 52076116Sdcs if (isPrimitive(pFW)) 52176116Sdcs { 52294290Sdcs strcat(pVM->pad, " ( primitive )"); 52376116Sdcs } 52494290Sdcs#endif 52576116Sdcs 52676116Sdcs vmTextOut(pVM, pVM->pad, 1); 52794290Sdcs debugPrompt(pVM); 52876116Sdcs } 52976116Sdcs else 53076116Sdcs { 53176116Sdcs pVM->fRestart = 0; 53276116Sdcs } 53376116Sdcs 53476116Sdcs si = vmGetWord(pVM); 53576116Sdcs 53676116Sdcs if (!strincmp(si.cp, "i", si.count)) 53776116Sdcs { 53876116Sdcs stepIn(pVM); 53976116Sdcs } 54076116Sdcs else if (!strincmp(si.cp, "g", si.count)) 54176116Sdcs { 54276116Sdcs return; 54376116Sdcs } 54494290Sdcs else if (!strincmp(si.cp, "l", si.count)) 54594290Sdcs { 54694290Sdcs FICL_WORD *xt; 54794290Sdcs xt = findEnclosingWord(pVM, (CELL *)(pVM->ip)); 54894290Sdcs if (xt) 54994290Sdcs { 55094290Sdcs stackPushPtr(pVM->pStack, xt); 55194290Sdcs seeXT(pVM); 55294290Sdcs } 55394290Sdcs else 55494290Sdcs { 55594290Sdcs vmTextOut(pVM, "sorry - can't do that", 1); 55694290Sdcs } 55794290Sdcs vmThrow(pVM, VM_RESTART); 55894290Sdcs } 55976116Sdcs else if (!strincmp(si.cp, "o", si.count)) 56076116Sdcs { 56176116Sdcs stepOver(pVM); 56276116Sdcs } 56376116Sdcs else if (!strincmp(si.cp, "q", si.count)) 56476116Sdcs { 56594290Sdcs ficlTextOut(pVM, FICL_PROMPT, 0); 56676116Sdcs vmThrow(pVM, VM_ABORT); 56776116Sdcs } 56894290Sdcs else if (!strincmp(si.cp, "x", si.count)) 56994290Sdcs { 57094290Sdcs /* 57194290Sdcs ** Take whatever's left in the TIB and feed it to a subordinate ficlExec 57294290Sdcs */ 57394290Sdcs int ret; 57494290Sdcs char *cp = pVM->tib.cp + pVM->tib.index; 57594290Sdcs int count = pVM->tib.end - cp; 57694290Sdcs FICL_WORD *oldRun = pVM->runningWord; 57794290Sdcs 57894290Sdcs ret = ficlExecC(pVM, cp, count); 57994290Sdcs 58094290Sdcs if (ret == VM_OUTOFTEXT) 58194290Sdcs { 58294290Sdcs ret = VM_RESTART; 58394290Sdcs pVM->runningWord = oldRun; 58494290Sdcs vmTextOut(pVM, "", 1); 58594290Sdcs } 58694290Sdcs 58794290Sdcs vmThrow(pVM, ret); 58894290Sdcs } 58976116Sdcs else 59076116Sdcs { 59176116Sdcs vmTextOut(pVM, "i -- step In", 1); 59276116Sdcs vmTextOut(pVM, "o -- step Over", 1); 59376116Sdcs vmTextOut(pVM, "g -- Go (execute to completion)", 1); 59494290Sdcs vmTextOut(pVM, "l -- List source code", 1); 59576116Sdcs vmTextOut(pVM, "q -- Quit (stop debugging and abort)", 1); 59694290Sdcs vmTextOut(pVM, "x -- eXecute the rest of the line as ficl words", 1); 59794290Sdcs debugPrompt(pVM); 59876116Sdcs vmThrow(pVM, VM_RESTART); 59976116Sdcs } 60076116Sdcs 60176116Sdcs return; 60276116Sdcs} 60376116Sdcs 60476116Sdcs 60576116Sdcs/************************************************************************** 60676116Sdcs b y e 60776116Sdcs** TOOLS 60876116Sdcs** Signal the system to shut down - this causes ficlExec to return 60976116Sdcs** VM_USEREXIT. The rest is up to you. 61076116Sdcs**************************************************************************/ 61176116Sdcsstatic void bye(FICL_VM *pVM) 61276116Sdcs{ 61376116Sdcs vmThrow(pVM, VM_USEREXIT); 61476116Sdcs return; 61576116Sdcs} 61676116Sdcs 61776116Sdcs 61876116Sdcs/************************************************************************** 61976116Sdcs d i s p l a y S t a c k 62076116Sdcs** TOOLS 62176116Sdcs** Display the parameter stack (code for ".s") 62276116Sdcs**************************************************************************/ 62394290Sdcsstatic void displayPStack(FICL_VM *pVM) 62476116Sdcs{ 62594290Sdcs FICL_STACK *pStk = pVM->pStack; 62694290Sdcs int d = stackDepth(pStk); 62776116Sdcs int i; 62876116Sdcs CELL *pCell; 62976116Sdcs 63076116Sdcs vmCheckStack(pVM, 0, 0); 63176116Sdcs 63276116Sdcs if (d == 0) 63376116Sdcs vmTextOut(pVM, "(Stack Empty) ", 0); 63476116Sdcs else 63576116Sdcs { 63694290Sdcs pCell = pStk->base; 63776116Sdcs for (i = 0; i < d; i++) 63876116Sdcs { 63976116Sdcs vmTextOut(pVM, ltoa((*pCell++).i, pVM->pad, pVM->base), 0); 64076116Sdcs vmTextOut(pVM, " ", 0); 64176116Sdcs } 64276116Sdcs } 64394290Sdcs return; 64476116Sdcs} 64576116Sdcs 64676116Sdcs 64776116Sdcsstatic void displayRStack(FICL_VM *pVM) 64876116Sdcs{ 64994290Sdcs FICL_STACK *pStk = pVM->rStack; 65094290Sdcs int d = stackDepth(pStk); 65176116Sdcs int i; 65276116Sdcs CELL *pCell; 65394290Sdcs FICL_DICT *dp = vmGetDict(pVM); 65476116Sdcs 65594290Sdcs vmCheckStack(pVM, 0, 0); 65694290Sdcs 65776116Sdcs if (d == 0) 65894290Sdcs vmTextOut(pVM, "(Stack Empty) ", 0); 65976116Sdcs else 66076116Sdcs { 66194290Sdcs pCell = pStk->base; 66276116Sdcs for (i = 0; i < d; i++) 66376116Sdcs { 66494290Sdcs CELL c = *pCell++; 66594290Sdcs /* 66694290Sdcs ** Attempt to find the word that contains the 66794290Sdcs ** stacked address (as if it is part of a colon definition). 66894290Sdcs ** If this works, print the name of the word. Otherwise print 66994290Sdcs ** the value as a number. 67094290Sdcs */ 67194290Sdcs if (dictIncludes(dp, c.p)) 67294290Sdcs { 67394290Sdcs FICL_WORD *pFW = findEnclosingWord(pVM, c.p); 67494290Sdcs if (pFW) 67594290Sdcs { 67694290Sdcs int offset = (CELL *)c.p - &pFW->param[0]; 67794290Sdcs sprintf(pVM->pad, "%s+%d ", pFW->name, offset); 67894290Sdcs vmTextOut(pVM, pVM->pad, 0); 67994290Sdcs continue; /* no need to print the numeric value */ 68094290Sdcs } 68194290Sdcs } 68294290Sdcs vmTextOut(pVM, ltoa(c.i, pVM->pad, pVM->base), 0); 68376116Sdcs vmTextOut(pVM, " ", 0); 68476116Sdcs } 68576116Sdcs } 68694290Sdcs 68794290Sdcs return; 68876116Sdcs} 68976116Sdcs 69076116Sdcs 69176116Sdcs/************************************************************************** 69276116Sdcs f o r g e t - w i d 69376116Sdcs** 69476116Sdcs**************************************************************************/ 69576116Sdcsstatic void forgetWid(FICL_VM *pVM) 69676116Sdcs{ 69794290Sdcs FICL_DICT *pDict = vmGetDict(pVM); 69876116Sdcs FICL_HASH *pHash; 69976116Sdcs 70076116Sdcs pHash = (FICL_HASH *)stackPopPtr(pVM->pStack); 70176116Sdcs hashForget(pHash, pDict->here); 70276116Sdcs 70376116Sdcs return; 70476116Sdcs} 70576116Sdcs 70676116Sdcs 70776116Sdcs/************************************************************************** 70876116Sdcs f o r g e t 70976116Sdcs** TOOLS EXT ( "<spaces>name" -- ) 71076116Sdcs** Skip leading space delimiters. Parse name delimited by a space. 71176116Sdcs** Find name, then delete name from the dictionary along with all 71276116Sdcs** words added to the dictionary after name. An ambiguous 71376116Sdcs** condition exists if name cannot be found. 71476116Sdcs** 71576116Sdcs** If the Search-Order word set is present, FORGET searches the 71676116Sdcs** compilation word list. An ambiguous condition exists if the 71776116Sdcs** compilation word list is deleted. 71876116Sdcs**************************************************************************/ 71976116Sdcsstatic void forget(FICL_VM *pVM) 72076116Sdcs{ 72176116Sdcs void *where; 72294290Sdcs FICL_DICT *pDict = vmGetDict(pVM); 72376116Sdcs FICL_HASH *pHash = pDict->pCompile; 72476116Sdcs 72576116Sdcs ficlTick(pVM); 72676116Sdcs where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name; 72776116Sdcs hashForget(pHash, where); 72876116Sdcs pDict->here = PTRtoCELL where; 72976116Sdcs 73076116Sdcs return; 73176116Sdcs} 73276116Sdcs 73376116Sdcs 73476116Sdcs/************************************************************************** 73576116Sdcs l i s t W o r d s 73676116Sdcs** 73776116Sdcs**************************************************************************/ 73876116Sdcs#define nCOLWIDTH 8 73976116Sdcsstatic void listWords(FICL_VM *pVM) 74076116Sdcs{ 74194290Sdcs FICL_DICT *dp = vmGetDict(pVM); 74276116Sdcs FICL_HASH *pHash = dp->pSearch[dp->nLists - 1]; 74376116Sdcs FICL_WORD *wp; 74476116Sdcs int nChars = 0; 74576116Sdcs int len; 74676116Sdcs int y = 0; 74776116Sdcs unsigned i; 74876116Sdcs int nWords = 0; 74976116Sdcs char *cp; 75076116Sdcs char *pPad = pVM->pad; 75176116Sdcs 75276116Sdcs for (i = 0; i < pHash->size; i++) 75376116Sdcs { 75476116Sdcs for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++) 75576116Sdcs { 75676116Sdcs if (wp->nName == 0) /* ignore :noname defs */ 75776116Sdcs continue; 75876116Sdcs 75976116Sdcs cp = wp->name; 76076116Sdcs nChars += sprintf(pPad + nChars, "%s", cp); 76176116Sdcs 76276116Sdcs if (nChars > 70) 76376116Sdcs { 76476116Sdcs pPad[nChars] = '\0'; 76576116Sdcs nChars = 0; 76676116Sdcs y++; 76776116Sdcs if(y>23) { 76876116Sdcs y=0; 76976116Sdcs vmTextOut(pVM, "--- Press Enter to continue ---",0); 77076116Sdcs getchar(); 77176116Sdcs vmTextOut(pVM,"\r",0); 77276116Sdcs } 77376116Sdcs vmTextOut(pVM, pPad, 1); 77476116Sdcs } 77576116Sdcs else 77676116Sdcs { 77776116Sdcs len = nCOLWIDTH - nChars % nCOLWIDTH; 77876116Sdcs while (len-- > 0) 77976116Sdcs pPad[nChars++] = ' '; 78076116Sdcs } 78176116Sdcs 78276116Sdcs if (nChars > 70) 78376116Sdcs { 78476116Sdcs pPad[nChars] = '\0'; 78576116Sdcs nChars = 0; 78676116Sdcs y++; 78776116Sdcs if(y>23) { 78876116Sdcs y=0; 78976116Sdcs vmTextOut(pVM, "--- Press Enter to continue ---",0); 79076116Sdcs getchar(); 79176116Sdcs vmTextOut(pVM,"\r",0); 79276116Sdcs } 79376116Sdcs vmTextOut(pVM, pPad, 1); 79476116Sdcs } 79576116Sdcs } 79676116Sdcs } 79776116Sdcs 79876116Sdcs if (nChars > 0) 79976116Sdcs { 80076116Sdcs pPad[nChars] = '\0'; 80176116Sdcs nChars = 0; 80276116Sdcs vmTextOut(pVM, pPad, 1); 80376116Sdcs } 80476116Sdcs 80576116Sdcs sprintf(pVM->pad, "Dictionary: %d words, %ld cells used of %u total", 80676116Sdcs nWords, (long) (dp->here - dp->dict), dp->size); 80776116Sdcs vmTextOut(pVM, pVM->pad, 1); 80876116Sdcs return; 80976116Sdcs} 81076116Sdcs 81176116Sdcs 81276116Sdcs/************************************************************************** 81376116Sdcs l i s t E n v 81476116Sdcs** Print symbols defined in the environment 81576116Sdcs**************************************************************************/ 81676116Sdcsstatic void listEnv(FICL_VM *pVM) 81776116Sdcs{ 81894290Sdcs FICL_DICT *dp = pVM->pSys->envp; 81976116Sdcs FICL_HASH *pHash = dp->pForthWords; 82076116Sdcs FICL_WORD *wp; 82176116Sdcs unsigned i; 82276116Sdcs int nWords = 0; 82376116Sdcs 82476116Sdcs for (i = 0; i < pHash->size; i++) 82576116Sdcs { 82676116Sdcs for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++) 82776116Sdcs { 82876116Sdcs vmTextOut(pVM, wp->name, 1); 82976116Sdcs } 83076116Sdcs } 83176116Sdcs 83276116Sdcs sprintf(pVM->pad, "Environment: %d words, %ld cells used of %u total", 83376116Sdcs nWords, (long) (dp->here - dp->dict), dp->size); 83476116Sdcs vmTextOut(pVM, pVM->pad, 1); 83576116Sdcs return; 83676116Sdcs} 83776116Sdcs 83876116Sdcs 83976116Sdcs/************************************************************************** 84076116Sdcs e n v C o n s t a n t 84176116Sdcs** Ficl interface to ficlSetEnv and ficlSetEnvD - allow ficl code to set 84276116Sdcs** environment constants... 84376116Sdcs**************************************************************************/ 84476116Sdcsstatic void envConstant(FICL_VM *pVM) 84576116Sdcs{ 84676116Sdcs unsigned value; 84776116Sdcs 84876116Sdcs#if FICL_ROBUST > 1 84976116Sdcs vmCheckStack(pVM, 1, 0); 85076116Sdcs#endif 85176116Sdcs 85276116Sdcs vmGetWordToPad(pVM); 85376116Sdcs value = POPUNS(); 85494290Sdcs ficlSetEnv(pVM->pSys, pVM->pad, (FICL_UNS)value); 85576116Sdcs return; 85676116Sdcs} 85776116Sdcs 85876116Sdcsstatic void env2Constant(FICL_VM *pVM) 85976116Sdcs{ 86076116Sdcs unsigned v1, v2; 86176116Sdcs 86276116Sdcs#if FICL_ROBUST > 1 86376116Sdcs vmCheckStack(pVM, 2, 0); 86476116Sdcs#endif 86576116Sdcs 86676116Sdcs vmGetWordToPad(pVM); 86776116Sdcs v2 = POPUNS(); 86876116Sdcs v1 = POPUNS(); 86994290Sdcs ficlSetEnvD(pVM->pSys, pVM->pad, v1, v2); 87076116Sdcs return; 87176116Sdcs} 87276116Sdcs 87376116Sdcs 87476116Sdcs/************************************************************************** 87576116Sdcs f i c l C o m p i l e T o o l s 87676116Sdcs** Builds wordset for debugger and TOOLS optional word set 87776116Sdcs**************************************************************************/ 87876116Sdcs 87976116Sdcsvoid ficlCompileTools(FICL_SYSTEM *pSys) 88076116Sdcs{ 88176116Sdcs FICL_DICT *dp = pSys->dp; 88276116Sdcs assert (dp); 88376116Sdcs 88476116Sdcs /* 88576116Sdcs ** TOOLS and TOOLS EXT 88676116Sdcs */ 88794290Sdcs dictAppendWord(dp, ".s", displayPStack, FW_DEFAULT); 88876116Sdcs dictAppendWord(dp, "bye", bye, FW_DEFAULT); 88976116Sdcs dictAppendWord(dp, "forget", forget, FW_DEFAULT); 89076116Sdcs dictAppendWord(dp, "see", see, FW_DEFAULT); 89176116Sdcs dictAppendWord(dp, "words", listWords, FW_DEFAULT); 89276116Sdcs 89376116Sdcs /* 89476116Sdcs ** Set TOOLS environment query values 89576116Sdcs */ 89694290Sdcs ficlSetEnv(pSys, "tools", FICL_TRUE); 89794290Sdcs ficlSetEnv(pSys, "tools-ext", FICL_FALSE); 89876116Sdcs 89976116Sdcs /* 90076116Sdcs ** Ficl extras 90176116Sdcs */ 90294290Sdcs dictAppendWord(dp, "r.s", displayRStack, FW_DEFAULT); /* guy carver */ 90376116Sdcs dictAppendWord(dp, ".env", listEnv, FW_DEFAULT); 90476116Sdcs dictAppendWord(dp, "env-constant", 90576116Sdcs envConstant, FW_DEFAULT); 90676116Sdcs dictAppendWord(dp, "env-2constant", 90776116Sdcs env2Constant, FW_DEFAULT); 90876116Sdcs dictAppendWord(dp, "debug-xt", ficlDebugXT, FW_DEFAULT); 90976116Sdcs dictAppendWord(dp, "parse-order", 91076116Sdcs ficlListParseSteps, 91176116Sdcs FW_DEFAULT); 91276116Sdcs dictAppendWord(dp, "step-break",stepBreak, FW_DEFAULT); 91376116Sdcs dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT); 91476116Sdcs dictAppendWord(dp, "see-xt", seeXT, FW_DEFAULT); 91576116Sdcs 91676116Sdcs return; 91776116Sdcs} 91876116Sdcs 919