ref: ca455597fd9acdc4f1b86e1cb62ee294a4c3bde9
parent: ce2526daa8a2145efa1a242c39d04b512223d677
author: jsadler <jsadler@ficl.sf.net>
date: Fri Jun 9 14:18:23 CDT 2000
intermediate check-in for rev 205
--- a/ReadMe.txt
+++ b/ReadMe.txt
@@ -1,6 +1,12 @@
Coming up:
Web server scripting extension (GoAhead port)
+"Private" flag for methods?
+method: defining word for public methods
+my=>
+catch a method invocation
+2value 2variable
+
ficlwin Debugger pane - step, stack trace, breakpoint
Design:
0. Debug pane or window - step-into step-over go
@@ -9,15 +15,21 @@
3. GO runs until breakpoint or leaves debug mode if no breaks
4. BREAK stops debug vm at next step
Requires a debug VM that checks for breaks, step mode, etc.
+How to get stack parameters to execution vm, or get input text to debug vm?
-rel 2.05
+>>> rel 2.05
Alpha patches from the freeBSD team incorporated
Split SEARCH and SEARCH EXT words form words.c to search.c
+ABORT" now complies with the ANS (-2 THROWs)
+2LOCALS in jhlocal syntax now lose the first 2 in their names.
+
+ANS DOUBLE words: 2r@ 2r> 2>r
+
ficl words
- wid-get-name given a wid, returns the address and count of its name. If no name, count is 0
- wid-set-name set optional wid name pointer to the \0 terminated string address specified.
- last-word returns the xt of the word being defined or most recently defined.
-- i@ and i! operate on quadbyte quantities for 64 bit friendliness
+- q@ and q! operate on quadbyte quantities for 64 bit friendliness
softcore.fr words
- ORDER now lists wordlists by name
- ficl-named-wordlist
--- a/dict.c
+++ b/dict.c
@@ -3,7 +3,7 @@
** Forth Inspired Command Language - dictionary methods
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
-**
+** $Header: /home/grobe0ba/cvs/ficl/Attic/dict.c,v 1.5 2000/06/09 19:18:19 jsadler Exp $
*******************************************************************/
/*
** This file implements the dictionary -- FICL's model of
--- 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
-**
+** $Header: /home/grobe0ba/cvs/ficl/Attic/ficl.c,v 1.5 2000/06/09 19:18:18 jsadler Exp $
*******************************************************************/
/*
** This is an ANS Forth interpreter written in C.
--- 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
-**
+** $Header: /home/grobe0ba/cvs/ficl/ficl.h,v 1.6 2000/06/09 19:18:15 jsadler Exp $
*******************************************************************/
/*
** N O T I C E -- DISCLAIMER OF WARRANTY
@@ -487,7 +487,6 @@
#define FW_IMMEDIATE 1 /* execute me even if compiling */
#define FW_COMPILE 2 /* error if executed when not compiling */
#define FW_SMUDGE 4 /* definition in progress - hide me */
-#define FW_CLASS 8 /* Word defines a class */
#define FW_COMPIMMED (FW_IMMEDIATE | FW_COMPILE)
#define FW_DEFAULT 0
--- a/math64.c
+++ b/math64.c
@@ -5,6 +5,7 @@
** Created: 25 January 1998
** Rev 2.03: Support for 128 bit DP math. This file really ouught to
** be renamed!
+** $Header: /home/grobe0ba/cvs/ficl/Attic/math64.c,v 1.2 2000/06/09 19:18:18 jsadler Exp $
*******************************************************************/
#include "ficl.h"
--- a/math64.h
+++ b/math64.h
@@ -3,7 +3,7 @@
** Forth Inspired Command Language - 64 bit math support routines
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 25 January 1998
-**
+** $Header: /home/grobe0ba/cvs/ficl/Attic/math64.h,v 1.2 2000/06/09 19:18:20 jsadler Exp $
*******************************************************************/
/*
** N O T I C E -- DISCLAIMER OF WARRANTY
--- a/search.c
+++ b/search.c
@@ -4,7 +4,7 @@
** ANS Forth SEARCH and SEARCH-EXT word-set written in C
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 6 June 2000
-**
+** $Header: /home/grobe0ba/cvs/ficl/search.c,v 1.1 2000/06/09 19:18:17 jsadler Exp $
*******************************************************************/
#include <string.h>
--- a/softwords/classes.fr
+++ b/softwords/classes.fr
@@ -36,8 +36,8 @@
object subclass c-4byte
4 chars: .payload
- : get drop i@ ;
- : set drop i! ;
+ : get drop q@ ;
+ : set drop q! ;
end-class
@@ -103,11 +103,10 @@
;
\ index the pointer in place
- : index-ptr ( index inst class -- )
- locals| class inst index |
- inst class c-ptr => get-ptr ( addr )
- inst class --> @size index * + ( addr' )
- inst class c-ptr => set-ptr
+ : index-ptr { index 2this -- }+ this --> get-ptr ( addr )
+ this --> @size index * + ( addr' )
+ this --> set-ptr
;
end-class
@@ -133,10 +132,10 @@
: @size 2drop 4 ;
\ fetch and store through the pointer
: get ( inst class -- value )
- c-ptr => get-ptr i@
+ c-ptr => get-ptr q@
;
: set ( value inst class -- )
- c-ptr => get-ptr i!
+ c-ptr => get-ptr q!
;
end-class
--- a/softwords/forml.fr
+++ b/softwords/forml.fr
@@ -20,8 +20,8 @@
;
: set-name { c-addr u 2this -- }- u 2this --> .length --> set
- c-addr 2this --> .name u move
+ u this --> .length --> set
+ c-addr this --> .name u move
;
: ? ( inst class ) c-example => get-name type cr ;
@@ -48,15 +48,15 @@
c-byte obj: .state
: on { led# 2this -- }- 2this --> .state --> get
+ this --> .state --> get
1 led# lshift or dup !oreg
- 2this --> .state --> set
+ this --> .state --> set
;
: off { led# 2this -- }- 2this --> .state --> get
+ this --> .state --> get
1 led# lshift invert and dup !oreg
- 2this --> .state --> set
+ this --> .state --> set
;
end-class
--- a/softwords/jhlocal.fr
+++ b/softwords/jhlocal.fr
@@ -24,10 +24,15 @@
: ?| ( c-addr u -- c-addr u flag )
2dup s" |" compare 0= ;
-\ examine name and push true if it's a 2local
-\ (starts with '2'), false otherwise.
-: ?2loc ( c-addr u -- c-addr n flag )
- over c@ [char] 2 = if true else false endif ;
+\ examine name - if it's a 2local (starts with '2'),
+\ nibble the first char (the '2') off the name and push true.
+\ Otherwise push false
+: ?2loc ( c-addr u -- c-addr u flag )
+ over c@ [char] 2 =
+ if
+ 1- swap char+ swap \ dcs/jws: nibble the '2'
+ true
+ else false endif ;
: ?delim ( c-addr u -- state | c-addr u 0 )
?| if 2drop 1 exit endif
--- a/softwords/oo.fr
+++ b/softwords/oo.fr
@@ -345,8 +345,8 @@
\ end-class ( done with c-akbar )
\
: resume-class { 2this -- old-wid addr[size] size }- 2this --> .wid @ ficl-set-current ( old-wid )
- 2this --> .size dup @ ( old-wid addr[size] size )
+ this --> .wid @ ficl-set-current ( old-wid )
+ this --> .size dup @ ( old-wid addr[size] size )
instance-vars >search
;
--- a/softwords/string.fr
+++ b/softwords/string.fr
@@ -30,8 +30,8 @@
: get-buf ( 2this -- ptr ) c-string => .buf c-ptr => get-ptr ;
: set-buf { ptr len 2this -- } - ptr 2this c-string => .buf c-ptr => set-ptr
- len 2this c-string => set-buflen
+ ptr this c-string => .buf c-ptr => set-ptr
+ len this c-string => set-buflen
;
\ set buffer to null and buflen to zero
@@ -42,11 +42,11 @@
\ free the buffer if there is one, set buf pointer to null
: free-buf { 2this -- }- 2this c-string => get-buf
+ this c-string => get-buf
?dup if
free
abort" c-string free failed"
- 2this c-string => clr-buf
+ this c-string => clr-buf
endif
;
@@ -54,7 +54,7 @@
: size-buf { size 2this -- }size 0< abort" need positive size for size-buf"
size 0= if
- 2this --> free-buf exit
+ this --> free-buf exit
endif
\ force buflen to be a positive multiple of min-buf chars
@@ -61,45 +61,45 @@
c-string => min-buf size over / 1+ * chars to size
\ if buffer is null, allocate one, else resize it
- 2this --> get-buflen 0=
+ this --> get-buflen 0=
if
size allocate
abort" out of memory"
- size 2this --> set-buf
- size 2this --> set-buflen
+ size this --> set-buf
+ size this --> set-buflen
exit
endif
- size 2this --> get-buflen > if
- 2this --> get-buf size resize
+ size this --> get-buflen > if
+ this --> get-buf size resize
abort" out of memory"
- size 2this --> set-buf
+ size this --> set-buf
endif
;
: set { c-addr u 2this -- }- u 2this --> size-buf
- u 2this --> set-count
- c-addr 2this --> get-buf u move
+ u this --> size-buf
+ u this --> set-count
+ c-addr this --> get-buf u move
;
: get { 2this -- c-addr u }- 2this --> get-buf
- 2this --> get-count
+ this --> get-buf
+ this --> get-count
;
\ append string to existing one
: cat { c-addr u 2this -- }- 2this --> get-count u + dup >r
- 2this --> size-buf
- c-addr 2this --> get-buf 2this --> get-count + u move
- r> 2this --> set-count
+ this --> get-count u + dup >r
+ this --> size-buf
+ c-addr this --> get-buf this --> get-count + u move
+ r> this --> set-count
;
: type { 2this -- }- 2this --> ?empty if ." (empty) " exit endif
- 2this --> .buf --> get-ptr
- 2this --> .count --> get
+ this --> ?empty if ." (empty) " exit endif
+ this --> .buf --> get-ptr
+ this --> .count --> get
type
;
@@ -123,8 +123,8 @@
c-2byte obj: .hashcode
: set-hashcode { 2this -- }- 2this --> super --> hashcode
- 2this --> .hashcode --> set
+ this --> super --> hashcode
+ this --> .hashcode --> set
;
: get-hashcode ( 2this -- hashcode )
--- a/stack.c
+++ b/stack.c
@@ -3,7 +3,7 @@
** Forth Inspired Command Language
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 16 Oct 1997
-**
+** $Header: /home/grobe0ba/cvs/ficl/stack.c,v 1.2 2000/06/09 19:18:17 jsadler Exp $
*******************************************************************/
#include <stdlib.h>
--- a/sysdep.c
+++ b/sysdep.c
@@ -6,7 +6,7 @@
** Implementations of FICL external interface functions...
**
** (simple) port to Linux, Skip Carter 26 March 1998
-**
+** $Header: /home/grobe0ba/cvs/ficl/Attic/sysdep.c,v 1.3 2000/06/09 19:18:16 jsadler Exp $
*******************************************************************/
#include <stdlib.h>
--- a/sysdep.h
+++ b/sysdep.h
@@ -9,7 +9,7 @@
** FICL_ROBUST is enabled. This may require some consideration
** in firmware systems since assert often
** assumes stderr/stdout.
-**
+** $Header: /home/grobe0ba/cvs/ficl/Attic/sysdep.h,v 1.3 2000/06/09 19:18:20 jsadler Exp $
*******************************************************************/
/*
** N O T I C E -- DISCLAIMER OF WARRANTY
--- a/test/ficltest.fr
+++ b/test/ficltest.fr
@@ -19,6 +19,17 @@
load core.fr
{ -> }+\ test double stuff
+testing 2>r 2r> 2r@
+: 2r1 2>r r> r> swap ;
+: 2r2 swap >r >r 2r> ;
+: 2r3 2>r 2r@ R> R> 2DUP >R >R SWAP 2r> ;
+
+{ 1 2 2r1 -> 1 2 }+{ 1 2 2r2 -> 1 2 }+{ 1 2 2r3 -> 1 2 1 2 1 2 }+{ -> }+
\ Now test ficl extras and optional word-sets
testing locals
{ 1 2 3 local1 -> 3 2 1 0 }--- a/testmain.c
+++ b/testmain.c
@@ -1,6 +1,6 @@
/*
** stub main for testing FICL under Win32
-**
+** $Header: /home/grobe0ba/cvs/ficl/Attic/testmain.c,v 1.5 2000/06/09 19:18:16 jsadler Exp $
*/
#include <stdlib.h>
--- a/vm.c
+++ b/vm.c
@@ -3,7 +3,7 @@
** Forth Inspired Command Language - virtual machine methods
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
-**
+** $Header: /home/grobe0ba/cvs/ficl/vm.c,v 1.5 2000/06/09 19:18:19 jsadler Exp $
*******************************************************************/
/*
** This file implements the virtual machine of FICL. Each virtual
--- 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
-**
+** $Header: /home/grobe0ba/cvs/ficl/Attic/words.c,v 1.6 2000/06/09 19:18:11 jsadler Exp $
*******************************************************************/
#include <stdlib.h>
@@ -1857,6 +1857,36 @@
}
+static void twoToR(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
+ stackRoll(pVM->pStack, 1);
+ stackPush(pVM->rStack, stackPop(pVM->pStack));
+ stackPush(pVM->rStack, stackPop(pVM->pStack));
+ return;
+}
+
+static void twoRFrom(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 2);
+#endif
+ stackPush(pVM->pStack, stackPop(pVM->rStack));
+ stackPush(pVM->pStack, stackPop(pVM->rStack));
+ stackRoll(pVM->pStack, 1);
+ return;
+}
+
+static void twoRFetch(FICL_VM *pVM)
+{+ stackPush(pVM->pStack, stackFetch(pVM->rStack, 1));
+ stackPush(pVM->pStack, stackFetch(pVM->rStack, 0));
+ return;
+}
+
+
/**************************************************************************
v a r i a b l e
**
@@ -4190,7 +4220,7 @@
dictAppendWord(dp, ">body", toBody, FW_DEFAULT);
dictAppendWord(dp, ">in", toIn, FW_DEFAULT);
dictAppendWord(dp, ">number", toNumber, FW_DEFAULT);
- dictAppendWord(dp, ">r", toRStack, FW_DEFAULT);
+ dictAppendWord(dp, ">r", toRStack, FW_COMPILE);
dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT);
dictAppendWord(dp, "@", fetch, FW_DEFAULT);
dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT);
@@ -4251,8 +4281,8 @@
dictAppendWord(dp, "over", over, FW_DEFAULT);
dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED);
dictAppendWord(dp, "quit", quit, FW_DEFAULT);
- dictAppendWord(dp, "r>", fromRStack, FW_DEFAULT);
- dictAppendWord(dp, "r@", fetchRStack, FW_DEFAULT);
+ dictAppendWord(dp, "r>", fromRStack, FW_COMPILE);
+ dictAppendWord(dp, "r@", fetchRStack, FW_COMPILE);
dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED);
dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED);
dictAppendWord(dp, "rot", rot, FW_DEFAULT);
@@ -4287,6 +4317,9 @@
*/
dictAppendWord(dp, ".(", dotParen, FW_DEFAULT);dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT);
+ dictAppendWord(dp, "2>r", twoToR, FW_COMPILE);
+ dictAppendWord(dp, "2r>", twoRFrom, FW_COMPILE);
+ dictAppendWord(dp, "2r@", twoRFetch, FW_COMPILE);
dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED);
dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED);
dictAppendWord(dp, "parse", parse, FW_DEFAULT);
@@ -4331,7 +4364,7 @@
dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT);
ficlSetEnv("exception", FICL_TRUE);- ficlSetEnv("exception-ext", FICL_FALSE); /* abort" does not comply yet */+ ficlSetEnv("exception-ext", FICL_TRUE);/*
** LOCAL and LOCAL EXT
@@ -4418,8 +4451,8 @@
dictAppendWord(dp, "number?", ficlIsNum, FW_DEFAULT);
dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT);
dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */
- dictAppendWord(dp, "i@", quadFetch, FW_DEFAULT);
- dictAppendWord(dp, "i!", quadStore, FW_DEFAULT);
+ dictAppendWord(dp, "q@", quadFetch, FW_DEFAULT);
+ dictAppendWord(dp, "q!", quadStore, FW_DEFAULT);
dictAppendWord(dp, "w@", wFetch, FW_DEFAULT);
dictAppendWord(dp, "w!", wStore, FW_DEFAULT);
dictAppendWord(dp, "x.", hexDot, FW_DEFAULT);