ref: 38f0e73936f7e31c5bf14e43a0cc48b0d30f8709
parent: 5ccc4694222583669d6cbc2f9a8aeea280bc5e86
author: jsadler <jsadler@ficl.sf.net>
date: Sat Apr 28 14:02:04 CDT 2001
Added vtable support words from guy carver (forgotten in 2.05) Added debugger commands and usefulness Added f>s in float.c
--- a/ficl.c
+++ b/ficl.c
@@ -3,7 +3,7 @@
** Forth Inspired Command Language - external interface
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
-** $Id: ficl.c,v 1.10 2001/04/27 04:41:42 jsadler Exp $
+** $Id: ficl.c,v 1.11 2001/04/28 19:01:01 jsadler Exp $
*******************************************************************/
/*
** This is an ANS Forth interpreter written in C.
@@ -54,7 +54,7 @@
** if you would like to contribute to the ficl release, please send
** contact me by email at the address above.
**
-** $Id: ficl.c,v 1.10 2001/04/27 04:41:42 jsadler Exp $
+** $Id: ficl.c,v 1.11 2001/04/28 19:01:01 jsadler Exp $
*/
#include <stdlib.h>
@@ -123,7 +123,7 @@
** valid hex value otherwise.
*/
ficlCompilePrefix(pSys);
- ficlAddPrecompiledParseStep(pSys, "number?", ficlParseNumber);
+ ficlAddPrecompiledParseStep(pSys, ">number", ficlParseNumber);
/*
** Build the precompiled dictionary and load softwords. We need a temporary
--- a/ficl.dsp
+++ b/ficl.dsp
@@ -226,34 +226,42 @@
# End Group
# Begin Group "doc"
-# PROP Default_Filter ".html,.js"
+# PROP Default_Filter "*.html. *.txt"
# Begin Source File
-SOURCE=..\doc\ficl.html
+SOURCE=.\doc\ficl.html
# End Source File
# Begin Source File
-SOURCE=..\doc\ficl_debug.html
+SOURCE=.\doc\ficl_debug.html
# End Source File
# Begin Source File
-SOURCE=..\doc\ficl_loc.html
+SOURCE=.\doc\ficl_loc.html
# End Source File
# Begin Source File
-SOURCE=..\doc\ficl_oop.html
+SOURCE=.\doc\ficl_oop.html
# End Source File
# Begin Source File
-SOURCE=..\doc\ficl_rel.html
+SOURCE=.\doc\ficl_rel.html
# End Source File
# Begin Source File
-SOURCE=..\doc\ficlheader.js
+SOURCE=.\doc\ficlheader.js
# End Source File
# Begin Source File
-SOURCE=..\doc\oo_in_c.html
+SOURCE=.\doc\index.html
+# End Source File
+# Begin Source File
+
+SOURCE=.\doc\oo_in_c.html
+# End Source File
+# Begin Source File
+
+SOURCE=.\doc\primer.txt
# End Source File
# End Group
# Begin Source File
--- a/ficl.h
+++ b/ficl.h
@@ -3,7 +3,7 @@
** Forth Inspired Command Language
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
-** $Id: ficl.h,v 1.11 2001/04/27 04:41:48 jsadler Exp $
+** $Id: ficl.h,v 1.12 2001/04/28 19:01:18 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
@@ -39,7 +39,7 @@
** if you would like to contribute to the ficl release, please send
** contact me by email at the address above.
**
-** $Id: ficl.h,v 1.11 2001/04/27 04:41:48 jsadler Exp $
+** $Id: ficl.h,v 1.12 2001/04/28 19:01:18 jsadler Exp $
*/
#if !defined (__FICL_H__)
@@ -823,7 +823,6 @@
typedef struct ficl_system
{FICL_SYSTEM *link;
- FICL_WORD *parseList[FICL_MAX_PARSE_STEPS];
FICL_VM *vmList;
FICL_DICT *dp;
FICL_DICT *envp;
@@ -831,6 +830,7 @@
FICL_DICT *localp;
#endif
FICL_WORD *pInterp[3];
+ FICL_WORD *parseList[FICL_MAX_PARSE_STEPS];
} FICL_SYSTEM;
/*
--- a/float.c
+++ b/float.c
@@ -4,7 +4,7 @@
** ANS Forth FLOAT word-set written in C
** Author: Guy Carver & John Sadler (john_sadler@alum.mit.edu)
** Created: Apr 2001
-** $Id: float.c,v 1.1 2001/04/27 04:41:39 jsadler Exp $
+** $Id: float.c,v 1.2 2001/04/28 19:00:55 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
@@ -40,7 +40,7 @@
** if you would like to contribute to the ficl release, please send
** contact me by email at the address above.
**
-** $Id: float.c,v 1.1 2001/04/27 04:41:39 jsadler Exp $
+** $Id: float.c,v 1.2 2001/04/28 19:00:55 jsadler Exp $
*/
#include <stdlib.h>
@@ -767,15 +767,33 @@
}
-#define NUMISNEG 1
-#define EXPISNEG 2
+/*******************************************************************
+** Move float to param stack (assumes they both fit in a single CELL)
+** f>s
+*******************************************************************/
+static void FtoS(FICL_VM *pVM)
+{+ CELL c;
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 0);
+ vmCheckStack(pVM, 0, 1);
+#endif
+ c = stackPop(pVM->fStack);
+ stackPush(pVM->pStack, c);
+ return;
+}
+
+
/**************************************************************************
F l o a t P a r s e S t a t e
** Enum to determine the current segement of a floating point number
** being parsed.
**************************************************************************/
+#define NUMISNEG 1
+#define EXPISNEG 2
+
enum
{FPS_START,
@@ -994,6 +1012,8 @@
dictAppendWord(dp, "i-f", isubf, FW_DEFAULT);
dictAppendWord(dp, "i/f", idivf, FW_DEFAULT);
+ dictAppendWord(dp, "f>s", FtoS, FW_DEFAULT);
+
dictAppendWord(dp, "f-roll", FminusRoll, FW_DEFAULT);
dictAppendWord(dp, "f-rot", Fminusrot, FW_DEFAULT);
dictAppendWord(dp, "(fliteral)", fliteralParen, FW_COMPILE);
@@ -1002,7 +1022,7 @@
ficlSetEnv("floating-ext", FICL_FALSE); ficlSetEnv("floating-stack", FICL_DEFAULT_STACK);- ficlAddPrecompiledParseStep(pSys, "fnumber?", ficlParseFloatNumber);
+ ficlAddPrecompiledParseStep(pSys, ">float", ficlParseFloatNumber);
#endif
return;
}
\ No newline at end of file
--- a/softwords/oo.fr
+++ b/softwords/oo.fr
@@ -45,6 +45,10 @@
\ on the stack.
\ Overridden methods must maintain the same stack signature as
\ their predecessors. Ficl has no way of enforcing this, though.
+\
+\ Revised Apr 2001 - Added Guy Carver's vtable extensions. Class now
+\ has an extra field for the vtable method count. Hasvtable declares
+\ refs to vtable classes
user current-class
0 current-class !
@@ -61,22 +65,22 @@
: parse-method \ name run: ( -- c-addr u )
parse-word
- postpone sliteral
+ postpone sliteral
; compile-only
: lookup-method { class 2:name -- class xt }- name class cell+ @ ( c-addr u wid )
- search-wordlist ( 0 | xt 1 | xt -1 )
- 0= if
- name type ." not found in "
+ name class cell+ @ ( c-addr u wid )
+ search-wordlist ( 0 | xt 1 | xt -1 )
+ 0= if
+ name type ." not found in "
class body> >name type
cr abort
- endif
+ endif
class swap
;
: find-method-xt \ name ( class -- class xt )
- parse-word lookup-method
+ parse-word lookup-method
;
set-current ( stop hiding definitions )
@@ -95,9 +99,9 @@
\
: --> ( instance class -- ??? )
state @ 0= if
- find-method-xt execute
+ find-method-xt execute
else
- parse-method postpone exec-method
+ parse-method postpone exec-method
endif
; immediate
@@ -104,9 +108,9 @@
\ Method lookup with CATCH in case of exceptions
: c-> ( instance class -- ?? exc-flag )
state @ 0= if
- find-method-xt catch
+ find-method-xt catch
else
- parse-method postpone catch-method
+ parse-method postpone catch-method
endif
; immediate
@@ -129,7 +133,7 @@
instance-vars dup >search ficl-set-current
: => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method
- drop find-method-xt compile, drop
+ drop find-method-xt compile, drop
; immediate compile-only
: my=> \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class
@@ -163,7 +167,7 @@
\
: do-instance-var
does> ( instance class addr[offset] -- addr[field] )
- nip @ +
+ nip @ +
;
: addr-units: ( offset size "name" -- offset' )
@@ -171,14 +175,14 @@
do-instance-var
;
-: chars: \ ( offset nCells "name" -- offset' ) Create n char member.
+: chars: \ ( offset nCells "name" -- offset' ) Create n char member.
chars addr-units: ;
-: char: \ ( offset nCells "name" -- offset' ) Create 1 char member.
+: char: \ ( offset nCells "name" -- offset' ) Create 1 char member.
1 chars: ;
: cells: ( offset nCells "name" -- offset' )
- cells >r aligned r> addr-units:
+ cells >r aligned r> addr-units:
;
: cell: ( offset nCells "name" -- offset' )
@@ -189,17 +193,17 @@
\ Example: object obj: m_obj
\
: do-aggregate
- does> ( instance class pfa -- a-instance a-class )
- 2@ ( inst class a-class a-offset )
- 2swap drop ( a-class a-offset inst )
- + swap ( a-inst a-class )
+ does> ( instance class pfa -- a-instance a-class )
+ 2@ ( inst class a-class a-offset )
+ 2swap drop ( a-class a-offset inst )
+ + swap ( a-inst a-class )
;
: obj: ( offset class meta "name" -- offset' )
locals| meta class offset |
create offset , class ,
- class meta --> get-size offset +
- do-aggregate
+ class meta --> get-size offset +
+ do-aggregate
;
\ Aggregate an array of objects into a class
@@ -209,10 +213,10 @@
\ named my-array.
\
: array: ( offset n class meta "name" -- offset' )
- locals| meta class nobjs offset |
- create offset , class ,
- class meta --> get-size nobjs * offset +
- do-aggregate
+ locals| meta class nobjs offset |
+ create offset , class ,
+ class meta --> get-size nobjs * offset +
+ do-aggregate
;
\ Aggregate a pointer to an object: REF is a member variable
@@ -222,14 +226,34 @@
\ in classes.fr. REF is only useful for pre-initialized structures,
\ since there's no supported way to set one.
: ref: ( offset class meta "name" -- offset' )
- locals| meta class offset |
- create offset , class ,
- offset cell+
- does> ( inst class pfa -- ptr-inst ptr-class )
- 2@ ( inst class ptr-class ptr-offset )
- 2swap drop + @ swap
+ locals| meta class offset |
+ create offset , class ,
+ offset cell+
+ does> ( inst class pfa -- ptr-inst ptr-class )
+ 2@ ( inst class ptr-class ptr-offset )
+ 2swap drop + @ swap
;
+\ vcall extensions contributed by Guy Carver
+: vcall: ( paramcnt "name" -- )
+ current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined.
+ create , , \ ( paramcnt index -- )
+ does> \ ( inst class pfa -- ptr-inst ptr-class )
+ nip 2@ vcall \ ( params offset inst class offset -- )
+;
+
+: vcallr: 0x80000000 or vcall: ; \ Call with return address desired.
+
+\ #if FICL_WANT_FLOAT
+: vcallf: \ ( paramcnt -<name>- f: r )
+ 0x80000000 or
+ current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined.
+ create , , \ ( paramcnt index -- )
+ does> \ ( inst class pfa -- ptr-inst ptr-class )
+ nip 2@ vcall f>s \ ( params offset inst class offset -- f: r )
+;
+\ #endif
+
\ END-CLASS terminates construction of a class by storing
\ the size of its instance variables in the class's size field
\ ( -- old-wid addr[size] 0 )
@@ -236,7 +260,7 @@
\
: end-class ( old-wid addr[size] size -- )
swap ! set-current
- search> drop \ pop struct builder wordlist
+ search> drop \ pop struct builder wordlist
;
\ See resume-class (a metaclass method) below for usage
@@ -255,7 +279,7 @@
\ the wordlist of every class by the SUB method.
\ PRECONDITION: current-class contains the class address
\ why use a state variable instead of the stack?
-\ >> Stack state is not well-defined during compilation (there are
+\ >> Stack state is not well-defined during compilation (there are
\ >> control structure match codes on the stack, of undefined size
\ >> easiest way around this is use of this thread-local variable
\
@@ -273,14 +297,14 @@
\ See above...
\
:noname
- wordlist
- create
+ wordlist
+ create
immediate
- 0 , \ NULL parent class
- dup , \ wid
- 3 cells , \ instance size
- ficl-set-current
- does> dup
+ 0 , \ NULL parent class
+ dup , \ wid
+ 4 cells , \ instance size
+ ficl-set-current
+ does> dup
; execute metaclass
\ now brand OBJECT's wordlist (so that ORDER can display it by name)
metaclass drop cell+ @ brand-wordlist
@@ -299,12 +323,17 @@
create .wid ( class metaclass -- wid ) \ return wid of class
1 cells , do-instance-var
-create .size ( class metaclass -- size ) \ return class's payload size
+create .vtCount \ Number of VTABLE methods, if any
2 cells , do-instance-var
+create .size ( class metaclass -- size ) \ return class's payload size
+ 3 cells , do-instance-var
+
: get-size metaclass => .size @ ;
: get-wid metaclass => .wid @ ;
: get-super metaclass => .super @ ;
+: get-vtCount metaclass => .vtCount @ ;
+: get-vtAdd metaclass => .vtCount ;
\ create an uninitialized instance of a class, leaving
\ the address of the new instance and its class
@@ -311,7 +340,7 @@
\
: instance ( class metaclass "name" -- instance class )
locals| meta parent |
- create
+ create
here parent --> .do-instance \ ( inst class )
parent meta metaclass => get-size
allot \ allocate payload space
@@ -320,10 +349,10 @@
\ create an uninitialized array
: array ( n class metaclass "name" -- n instance class )
locals| meta parent nobj |
- create nobj
+ create nobj
here parent --> .do-instance \ ( nobj inst class )
parent meta metaclass => get-size
- nobj * allot \ allocate payload space
+ nobj * allot \ allocate payload space
;
\ create an initialized instance
@@ -334,8 +363,8 @@
\ create an initialized array of instances
: new-array ( n class metaclass "name" -- )
- metaclass => array
- --> array-init
+ metaclass => array
+ --> array-init
;
\ Create an anonymous initialized instance from the heap
@@ -405,19 +434,20 @@
\ Postcondition: leaves the address of the new class in current-class
: sub ( class metaclass "name" -- old-wid addr[size] size )
wordlist
- locals| wid meta parent |
- parent meta metaclass => get-wid
- wid wid-set-super \ set superclass
- create immediate \ get the subclass name
+ locals| wid meta parent |
+ parent meta metaclass => get-wid
+ wid wid-set-super \ set superclass
+ create immediate \ get the subclass name
wid brand-wordlist \ label the subclass wordlist
- here current-class ! \ prep for do-do-instance
- parent , \ save parent class
- wid , \ save wid
- here parent meta --> get-size dup , ( addr[size] size )
- metaclass => .do-instance
- wid ficl-set-current -rot
- do-do-instance
- instance-vars >search \ push struct builder wordlist
+ here current-class ! \ prep for do-do-instance
+ parent , \ save parent class
+ wid , \ save wid
+ parent meta --> get-vtCount ,
+ here parent meta --> get-size dup , ( addr[size] size )
+ metaclass => .do-instance
+ wid ficl-set-current -rot
+ do-do-instance
+ instance-vars >search \ push struct builder wordlist
;
\ OFFSET-OF returns the offset of an instance variable
@@ -429,27 +459,27 @@
\ ID returns the string name cell-pair of its class
: id ( class metaclass -- c-addr u )
- drop body> >name ;
+ drop body> >name ;
\ list methods of the class
: methods \ ( class meta -- )
- locals| meta class |
- begin
- class body> >name type ." methods:" cr
- class meta --> get-wid >search words cr previous
- class meta metaclass => get-super
- dup to class
- 0= until cr
+ locals| meta class |
+ begin
+ class body> >name type ." methods:" cr
+ class meta --> get-wid >search words cr previous
+ class meta metaclass => get-super
+ dup to class
+ 0= until cr
;
\ list class's ancestors
: pedigree ( class meta -- )
- locals| meta class |
- begin
- class body> >name type space
- class meta metaclass => get-super
- dup to class
- 0= until cr
+ locals| meta class |
+ begin
+ class body> >name type space
+ class meta metaclass => get-super
+ dup to class
+ 0= until cr
;
\ decompile a method
@@ -456,7 +486,12 @@
: see ( class meta -- )
metaclass => get-wid >search see previous ;
-previous set-current
+\ debug a method
+\ Eg: my-object --> debug my-method
+: debug ( class meta -- )
+ metaclass => get-wid >search debug previous ;
+
+previous set-current
\ E N D M E T A C L A S S
\ ** META is a nickname for the address of METACLASS...
@@ -468,18 +503,22 @@
\ This method is late bound for safety...
: subclass --> sub ;
+\ VTABLE Support extensions (Guy Carver)
+\ object --> sub mine hasvtable
+: hasvtable 4 + ; immediate
+
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ ** O B J E C T
\ Root of all classes
:noname
- wordlist
- create immediate
- 0 , \ NULL parent class
- dup , \ wid
- 0 , \ instance size
- ficl-set-current
- does> meta
+ wordlist
+ create immediate
+ 0 , \ NULL parent class
+ dup , \ wid
+ 0 , \ instance size
+ ficl-set-current
+ does> meta
; execute object
\ now brand OBJECT's wordlist (so that ORDER can display it by name)
object drop cell+ @ brand-wordlist
@@ -492,7 +531,7 @@
\ Convert instance cell-pair to class cell-pair
\ Useful for binding class methods from an instance
: class ( instance class -- class metaclass )
- nip meta ;
+ nip meta ;
\ default INIT method zero fills an instance
: init ( instance class -- )
@@ -503,18 +542,18 @@
\ Apply INIT to an array of NOBJ objects...
\
: array-init ( nobj inst class -- )
- 0 dup locals| &init &next class inst |
- \
- \ bind methods outside the loop to save time
- \
- class s" init" lookup-method to &init
- s" next" lookup-method to &next
- drop
- 0 ?do
- inst class 2dup
- &init execute
- &next execute drop to inst
- loop
+ 0 dup locals| &init &next class inst |
+ \
+ \ bind methods outside the loop to save time
+ \
+ class s" init" lookup-method to &init
+ s" next" lookup-method to &next
+ drop
+ 0 ?do
+ inst class 2dup
+ &init execute
+ &next execute drop to inst
+ loop
;
\ free storage allocated to a heap instance by alloc or alloc-array
@@ -521,8 +560,8 @@
\ NOTE: not protected against errors like FREEing something that's
\ really in the dictionary.
: free \ ( instance class -- )
- drop free
- abort" free failed "
+ drop free
+ abort" free failed "
;
\ Instance aliases for common class methods
@@ -531,15 +570,15 @@
meta metaclass => get-super ;
: pedigree ( instance class -- )
- object => class
+ object => class
metaclass => pedigree ;
: size ( instance class -- sizeof-instance )
- object => class
+ object => class
metaclass => get-size ;
: methods ( instance class -- )
- object => class
+ object => class
metaclass => methods ;
\ Array indexing methods...
@@ -548,27 +587,27 @@
\ obj --> next
\
: index ( n instance class -- instance[n] class )
- locals| class inst |
- inst class
+ locals| class inst |
+ inst class
object => class
- metaclass => get-size * ( n*size )
- inst + class ;
+ metaclass => get-size * ( n*size )
+ inst + class ;
: next ( instance[n] class -- instance[n+1] class )
- locals| class inst |
- inst class
+ locals| class inst |
+ inst class
object => class
- metaclass => get-size
- inst +
- class ;
+ metaclass => get-size
+ inst +
+ class ;
: prev ( instance[n] class -- instance[n-1] class )
- locals| class inst |
- inst class
+ locals| class inst |
+ inst class
object => class
- metaclass => get-size
- inst swap -
- class ;
+ metaclass => get-size
+ inst swap -
+ class ;
: debug ( 2this -- ?? )
find-method-xt debug-xt ;
--- a/softwords/softcore.fr
+++ b/softwords/softcore.fr
@@ -169,6 +169,7 @@
;
: debug ' debug-xt ;
+: on-step ." S: " .s cr ;
previous \ lose hidden words from search order
--- a/softwords/softcore.pl
+++ b/softwords/softcore.pl
@@ -53,7 +53,6 @@
** if you would like to contribute to the ficl release, please send
** contact me by email at the address above.
**
-** \$Id: softcore.pl,v 1.4 2001/04/27 04:41:13 jsadler Exp $
*/
--- a/tools.c
+++ b/tools.c
@@ -3,7 +3,7 @@
** Forth Inspired Command Language - programming tools
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 20 June 2000
-** $Id: tools.c,v 1.4 2001/04/27 04:41:24 jsadler Exp $
+** $Id: tools.c,v 1.5 2001/04/28 19:01:07 jsadler Exp $
*******************************************************************/
/*
** NOTES:
@@ -52,7 +52,7 @@
** if you would like to contribute to the ficl release, please send
** contact me by email at the address above.
**
-** $Id: tools.c,v 1.4 2001/04/27 04:41:24 jsadler Exp $
+** $Id: tools.c,v 1.5 2001/04/28 19:01:07 jsadler Exp $
*/
#include <stdlib.h>
@@ -96,6 +96,7 @@
{ FICL_WORD *pStep = ficlLookup("step-break");assert(pStep);
+
pBP->address = pVM->ip;
pBP->origXT = *pVM->ip;
*pVM->ip = pStep;
@@ -103,6 +104,15 @@
/*
+** debugPrompt
+*/
+static void debugPrompt(FICL_VM *pVM)
+{+ vmTextOut(pVM, "debug> ", 0);
+}
+
+
+/*
** isAFiclWord
** Vet a candidate pointer carefully to make sure
** it's not some chunk o' inline data...
@@ -332,12 +342,11 @@
** Run the colon code and set a breakpoint at the next instruction
*/
vmExecute(pVM, xt);
- bpStep.address = pVM->ip;
- bpStep.origXT = *pVM->ip;
- *pVM->ip = pStep;
+ vmSetBreak(pVM, &bpStep);
break;
default:
+ vmExecute(pVM, xt);
break;
}
@@ -428,20 +437,17 @@
{STRINGINFO si;
FICL_WORD *pFW;
- FICL_WORD *pOnStep = ficlLookup("on-step");+ FICL_WORD *pOnStep;
if (!pVM->fRestart)
{-
- assert(bpStep.address != NULL);
+ assert(bpStep.address);
+ assert(bpStep.origXT);
/*
** Clear the breakpoint that caused me to run
** Restore the original instruction at the breakpoint,
** and restore the IP
*/
- assert(bpStep.address);
- assert(bpStep.origXT);
-
pVM->ip = (IPTYPE)bpStep.address;
*pVM->ip = bpStep.origXT;
@@ -448,6 +454,7 @@
/*
** If there's an onStep, do it
*/
+ pOnStep = ficlLookup("on-step");if (pOnStep)
ficlExecXT(pVM, pOnStep);
@@ -462,6 +469,7 @@
}
vmTextOut(pVM, pVM->pad, 1);
+ debugPrompt(pVM);
}
else
{@@ -484,20 +492,40 @@
}
else if (!strincmp(si.cp, "q", si.count))
{+ ficlTextOut(pVM, FICL_PROMPT, 0);
vmThrow(pVM, VM_ABORT);
}
- else if (!strincmp(si.cp, "?", si.count))
+ else if (!strincmp(si.cp, "x", si.count))
{+ /*
+ ** Take whatever's left in the TIB and feed it to a subordinate ficlExec
+ */
+ int ret;
+ char *cp = pVM->tib.cp + pVM->tib.index;
+ int count = pVM->tib.end - cp;
+ FICL_WORD *oldRun = pVM->runningWord;
+
+ ret = ficlExecC(pVM, cp, count);
+
+ if (ret == VM_OUTOFTEXT)
+ {+ ret = VM_RESTART;
+ pVM->runningWord = oldRun;
+ debugPrompt(pVM);
+ }
+
+ vmThrow(pVM, ret);
+ }
+ else
+ {vmTextOut(pVM, "i -- step In", 1);
vmTextOut(pVM, "o -- step Over", 1);
vmTextOut(pVM, "g -- Go (execute to completion)", 1);
vmTextOut(pVM, "q -- Quit (stop debugging and abort)", 1);
+ vmTextOut(pVM, "x -- eXecute the rest of the line as ficl words", 1);
+ debugPrompt(pVM);
+ vmThrow(pVM, VM_RESTART);
}
- else
- {- vmTextOut(pVM, "unrecognized debug command", 1);
- vmThrow(pVM, VM_ABORT);
- }
return;
}
@@ -521,19 +549,17 @@
** TOOLS
** Display the parameter stack (code for ".s")
**************************************************************************/
-static void displayStack(FICL_VM *pVM)
+static void displayStack(FICL_VM *pVM, FICL_STACK *pStk)
{- int d = stackDepth(pVM->pStack);
+ int d = stackDepth(pStk);
int i;
CELL *pCell;
- vmCheckStack(pVM, 0, 0);
-
if (d == 0)
vmTextOut(pVM, "(Stack Empty) ", 0);
else
{- pCell = pVM->pStack->base;
+ pCell = pStk->base;
for (i = 0; i < d; i++)
{vmTextOut(pVM, ltoa((*pCell++).i, pVM->pad, pVM->base), 0);
@@ -540,27 +566,23 @@
vmTextOut(pVM, " ", 0);
}
}
+
+ return;
}
+static void displayPStack(FICL_VM *pVM)
+{+ vmCheckStack(pVM, 0, 0);
+ displayStack(pVM, pVM->pStack);
+ return;
+}
+
static void displayRStack(FICL_VM *pVM)
{- int d = stackDepth(pVM->rStack);
- int i;
- CELL *pCell;
-
- vmTextOut(pVM, "Return Stack: ", 0);
- if (d == 0)
- vmTextOut(pVM, "Empty ", 0);
- else
- {- pCell = pVM->rStack->base;
- for (i = 0; i < d; i++)
- {- vmTextOut(pVM, ultoa((*pCell++).i, pVM->pad, 16), 0);
- vmTextOut(pVM, " ", 0);
- }
- }
+ vmCheckStack(pVM, 0, 0);
+ displayStack(pVM, pVM->rStack);
+ return;
}
@@ -746,7 +768,7 @@
** TOOLS and TOOLS EXT
*/
dictAppendWord(dp, ".r", displayRStack, FW_DEFAULT); /* guy carver */
- dictAppendWord(dp, ".s", displayStack, FW_DEFAULT);
+ dictAppendWord(dp, ".s", displayPStack, FW_DEFAULT);
dictAppendWord(dp, "bye", bye, FW_DEFAULT);
dictAppendWord(dp, "forget", forget, FW_DEFAULT);
dictAppendWord(dp, "see", see, FW_DEFAULT);
@@ -773,7 +795,6 @@
dictAppendWord(dp, "step-break",stepBreak, FW_DEFAULT);
dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT);
dictAppendWord(dp, "see-xt", seeXT, FW_DEFAULT);
- dictAppendWord(dp, ".r", displayRStack, FW_DEFAULT);
return;
}
--- a/words.c
+++ b/words.c
@@ -4,7 +4,7 @@
** ANS Forth CORE word-set written in C
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
-** $Id: words.c,v 1.11 2001/04/27 04:41:15 jsadler Exp $
+** $Id: words.c,v 1.12 2001/04/28 19:01:28 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
@@ -40,7 +40,7 @@
** if you would like to contribute to the ficl release, please send
** contact me by email at the address above.
**
-** $Id: words.c,v 1.11 2001/04/27 04:41:15 jsadler Exp $
+** $Id: words.c,v 1.12 2001/04/28 19:01:28 jsadler Exp $
*/
#include <stdlib.h>
@@ -1225,6 +1225,7 @@
FICL_SYSTEM *pSys;
assert(pVM);
+
pSys = pVM->pSys;
si = vmGetWord0(pVM);
@@ -1339,6 +1340,16 @@
}
+static void lookup(FICL_VM *pVM)
+{+ STRINGINFO si;
+ SI_SETLEN(si, stackPopUNS(pVM->pStack));
+ SI_SETPTR(si, stackPopPtr(pVM->pStack));
+ stackPushINT(pVM->pStack, ficlParseWord(pVM, si));
+ return;
+}
+
+
/**************************************************************************
p a r e n P a r s e S t e p
** (parse-step) ( c-addr u -- flag )
@@ -4611,6 +4622,7 @@
dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE);
pInterpret =
dictAppendWord(dp, "interpret", interpret, FW_DEFAULT);
+ dictAppendWord(dp, "lookup", lookup, FW_DEFAULT);
dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE);
dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE);
dictAppendWord(dp, "(parse-step)",