commit 1cab5b4bf0325faf4027dc850ee8ca27cee7cd6f
parent 2e9c2cbf4958580cca908a3c1fafca04117d799c
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Fri, 23 Sep 2022 15:35:22 -0400
Add the ability to override the result of the next "word" call
This will be useful for structs in cc.
Diffstat:
4 files changed, 37 insertions(+), 4 deletions(-)
diff --git a/fs/tests/kernel.fs b/fs/tests/kernel.fs
@@ -6,6 +6,10 @@ testbegin
3 5 * 15 #eq
11 3 /mod 3 #eq ( q ) 2 #eq ( r )
+\ I/O
+: wordmaker word" hello" code 42 litn exit, ;
+wordmaker hello 42 #eq
+
\ to semantics
42 value foo
43 to foo
diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs
@@ -160,6 +160,7 @@ $20 const SPC $0d const CR $0a const LF $08 const BS
compiling if [compile] S" compile stype else
begin "< dup 0>= while emit repeat drop then ; immediate
: abort" [compile] ." compile abort ; immediate
+: word" [compile] S" NEXTWORD litn compile ! ; immediate
\ Return whether strings s1 and s2 are equal
: s= ( s1 s2 -- f ) over c@ 1+ []= ;
@@ -226,9 +227,9 @@ HERE ivalue here
_extends ?dup if
_curroot! 0 to@! _extends structdict' sysdict !
else
- sysdict S" :self" entry exit, \ :self is our root
+ word" :self" code exit, \ :self is our root
sysdict @ to _curroot then
- sysdict S" SZ" entry _cur e>w structsz' litn compile @ exit,
+ word" SZ" code _cur e>w structsz' litn compile @ exit,
does> ( 'struct )
@ ( 'dict ) word swap ( str 'dict ) find ( 'word )
?dup not if curword stype abort" not in namespace!" then
diff --git a/fs/xcomp/i386.fs b/fs/xcomp/i386.fs
@@ -25,7 +25,7 @@
\ Constants and labels
0 to realmode
: values ( n -- ) >r begin 0 value next ;
-25 values L1 L2 lblmainalias lblbootptr lblin< lblabort
+26 values L1 L2 lblmainalias lblbootptr lblin< lblabort lblnextword
lblcurword lblnextmeta lblret lblsysdict lblemit lblparsec lblparseh
lblparseud lblerrmsg lblrtype lblhere lbl[rcnt] lblmovewrite lblwrite
lblcwrite lblfind lblcompiling lblidt lblwoff
@@ -687,6 +687,11 @@ xcode IN< ( -- c )
lblin< pspushN,
ret,
+pc to lblnextword 0 ,
+xcode NEXTWORD
+ lblnextword pspushN,
+ ret,
+
pc to lblcurword $20 allot0
xcode curword
lblcurword pspushN,
@@ -699,7 +704,20 @@ pc to L1 ( word_eof )
AX pspush,
ret,
+pc \ we have a nonzero lblnextword
+ si lblnextword m) mov,
+ lblnextword m) 0 i) mov,
+ cx cx xor,
+ cl si 0 d) mov,
+ cl inc,
+ di lblcurword i) mov,
+ rep, movsb,
+ lblcurword pspushN,
+ ret,
+
xcode maybeword ( -- str-or-0 )
+ lblnextword m) -1 i) test,
+ ( pc ) abs>rel jnz,
\ save lbltoptr so that it doesn't mess in<, which could be calling a word
\ with "to" semantics.
ax lblwoff m) mov,
diff --git a/posix/vm.c b/posix/vm.c
@@ -31,7 +31,8 @@ The VM is little endian.
#define INRD (_RCNT_+4)
#define EMIT (INRD+4)
#define ABORT (EMIT+4)
-#define MAINLOOP (ABORT+4)
+#define NEXTWORD (ABORT+4)
+#define MAINLOOP (NEXTWORD+4)
#define CURWORD (MAINLOOP+4)
#define IOBUFSZ 0x200
#define IOBUF (SYSVARS-IOBUFSZ)
@@ -613,6 +614,13 @@ static void MAYBEWORD() { // op: 51
dword c, a;
// We have to save woff so that calls to in< don't mess with it
dword woff = vm.woff;
+ if ((a = gd(NEXTWORD))) {
+ sd(NEXTWORD, 0);
+ memchk(a+gb(a));
+ memcpy(&vm.mem[CURWORD], &vm.mem[a], gb(a)+1);
+ ppush(CURWORD);
+ return;
+ }
vm.woff = 0;
do {
callword(gd(INRD));
@@ -1072,6 +1080,7 @@ static void sysconst(char *name, dword val) {
static void buildsysdict() {
sd(HERE, 0);
+ sd(NEXTWORD, 0);
sd(SYSDICT, 0);
sd(SYSDICT+4, 0); // set 0 len byte. See doc/impl
entry("noop"); retwr();
@@ -1093,6 +1102,7 @@ static void buildsysdict() {
sysconst("ABORT", ABORT);
sysconst("MAIN", MAINLOOP);
sysconst("HERE", HERE);
+ sysconst("NEXTWORD", NEXTWORD);
sysconst("heremax", HEREMAX);
sysconst("curword", CURWORD);
sysconst("sysdict", SYSDICT);
