commit 8e8705fc2598f1c5b7e2032585030bf9d58faafb
parent 997c5cba462045157a695102fc6d2d7e0cc2b2ed
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Tue, 9 Aug 2022 23:10:04 -0400
Add new (to) native word
Diffstat:
5 files changed, 58 insertions(+), 25 deletions(-)
diff --git a/fs/doc/arch.txt b/fs/doc/arch.txt
@@ -176,8 +176,17 @@ obeys "to" semantics.
(alias): Compiled by "alias", it works like a (val), but it jumps to the address
read. Also obeys "to" semantics.
+(to): A generalized version of (val) and (alias), but slower and wider. It is
+followed by 12b of data, 2 word pointers and a 4 b data area. The first pointer
+is the "address getter". It is called with (to)+8 as an argument and returns
+an effective address for both the getter and the setter (the toptr). The getter
+returns the value from the effective address when toptr=0. PC then continues at
+(to)+12. For example, (val) would be "compile (to) ' noop , ' @ , $1234 ,"
+
(does): Compiled by "doer", it's a hybrid between (alias) and (cell). It pushes
PC+4 to PS, but also reads the 4b int at PC+0 and jumps to its address.
+Does *not* obey "to" semantics. We need it not to in order to have fancy does
+words that use the "to?" word.
(s): A string literal, compiled by S". It pushes PC+1 to PS, which is the
address of the first character of the string. Then, it reads the byte at PC+0,
diff --git a/fs/tests/kernel.fs b/fs/tests/kernel.fs
@@ -14,6 +14,15 @@ foo 43 #eq
foo 48 #eq
to' foo @ 48 #eq
+\ (to) word
+create foo 42 , 43 , 44 ,
+code ivalue ' (to) execute, ' @ , ' @ , foo , exit,
+ivalue 42 #eq
+4 to+ ivalue \ change the dereferenced address, not the address
+ivalue 46 #eq
+8 field myfield
+foo myfield 44 #eq
+
\ alias chaining
alias 1+ foo
: myfoo ( n 'foo -- n ) execute << ; \ (n+1)*2
diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs
@@ -85,8 +85,8 @@
: &c@ ( n -- ) doer , does> @ c@ ;
: &+@ ( n -- ) doer , does> @ + @ ;
: &+! ( n -- ) doer , does> @ + ! ;
-: ?toexec ( a -- ??? ) to? ?dup if execute else @ then ;
-: field ( off -- ) doer , does> ( a 'w ) @ + ?toexec ;
+: _ @ + ;
+: field ( off -- ) code compile (to) ['] _ , ['] @ , , exit, ;
\ A structure method. Called with a strucure as the top argument and will
\ execute the word pointer at a specific offset with that structure pointer
\ till on the top of PS.
@@ -174,23 +174,20 @@ alias noop [then]
\ Structure's structure:
\ 4b link to dict
\ 4b pointer to last instance used
-\ Field's structure:
-\ 4b offset
-
-: _getinst' ( 'struct -- ''inst ) CELLSZ + ;
-: _getinst ( 'struct -- 'inst ) _getinst' @ ;
-: (struct()) ( off 'struct -- a ) _getinst + ;
-: (struct) ( 'struct off ) swap _getinst + ?toexec ;
-: (struct:) ( 'struct off )
- swap _getinst + to? ?dup if execute else @ execute then ;
+
+: _getinst' ( 'struct -- ''inst ) CELLSZ + ;
+: _field' ( off 'struct -- a ) _getinst' @ + ;
+: _field'' ( 'struct 'off -- a ) @ swap _field' ;
: _parens ( 'struct off )
- compiling if litn litn compile (struct()) else swap (struct()) then ;
+ compiling if litn litn compile _field' else swap _field' then ;
: 'structsz ( 'struct -- sz ) @ llcnt CELLSZ * ;
: structsz ( w -- sz ) does' 'structsz ;
+: @execute @ execute ;
: struct ( cnt -- )
doer >r here 0 , 0 , 0 begin ( 'dict off )
- over word entry ( 'dict off ) dup litn
- curword 1+ c@ ':' = if compile (struct:) else compile (struct) then exit,
+ over word entry ( 'dict off )
+ compile (to) ['] _field'' ,
+ curword 1+ c@ ':' = if ['] @execute else ['] @ then , dup , exit,
CELLSZ + next ( 'dict off )
2drop immediate
does> ( ??? 'struct -- ??? *to* )
diff --git a/fs/xcomp/i386.fs b/fs/xcomp/i386.fs
@@ -24,10 +24,10 @@
\ Constants and labels
0 to realmode
: values ( n -- ) >r begin 0 value next ;
-25 values L1 L2 lblmainalias lbltoptr lbltoexec lblbootptr lblin< lblcurword
- lblnextmeta lblret lblsysdict lblemit lblparsec lblparseh lblparseud
- lblerrmsg lblrtype lblhere lblmovewrite lblwrite lblcwrite lblfind
- lblcompiling lblareg lblidt
+26 values L1 L2 lblmainalias lbltoptr lbltoexec lbltoexec2 lblbootptr lblin<
+ lblcurword lblnextmeta lblret lblsysdict lblemit lblparsec lblparseh
+ lblparseud lblerrmsg lblrtype lblhere lblmovewrite lblwrite lblcwrite
+ lblfind lblcompiling lblareg lblidt
$8000 const HERESTART \ TODO: find a better place
$500 to binstart
$2000 const STACKSZ
@@ -52,6 +52,7 @@ xcode noop pc to lblret ret,
align4 pc to lbltoptr 0 ,
pc to lbltoexec \ AX=cell addr
AX pspush,
+pc to lbltoexec2
bx lbltoptr m) mov,
lbltoptr m) 0 i) mov,
bx jmp,
@@ -75,6 +76,17 @@ xcode (alias)
lbltoexec abs>rel jnz,
ax 0 d) jmp,
+xcode (to)
+ ax sp 0 d) mov,
+ sp 0 d) 12 i) add,
+ AX pspush,
+ [ebp] 8 i) add,
+ ax 0 d) call,
+ lbltoptr m) -1 i) test,
+ lbltoexec2 abs>rel jnz,
+ ax sp 0 d) mov,
+ ax -8 ( 12-8 = 4 ) d) jmp,
+
xcode (does)
ax pop,
bx ax mov,
diff --git a/posix/vm.c b/posix/vm.c
@@ -242,12 +242,16 @@ static void SYSALIAS() { // op: 11
}
}
-static void SYSVAL() { // op: 12
- dword a = gpc();
+static void _TO_() { // op: 12
+ dword a = rpop();
+ rpush(a+12);
+ ppush(a+8);
+ callword(gd(a));
if (vm.toptr) {
- toexec(a);
+ vm.PC = vm.toptr;
+ vm.toptr = 0;
} else {
- ppush(gd(a));
+ callword(gd(a+4));
}
}
@@ -840,7 +844,7 @@ static void FCLOSE () { // op: 60
static void (*ops[OPCNT])() = {
JUMP, CALL, RET, LIT, BYE, BYEFAIL, QUIT, ABORT_,
EXECUTE, CELL, VAL, ALIAS, DOES, SLIT, BR, CBR,
- NEXT, SYSALIAS, SYSVAL, BOOTRD, STDOUT, STDERR, KEY, DROP,
+ NEXT, SYSALIAS, _TO_, BOOTRD, STDOUT, STDERR, KEY, DROP,
DUP, CDUP, SWAP, OVER, ROT, ROTR, NIP, TUCK,
RS2PS, PS2RS, RSGET, RDROP, SCNT, RCNT, ASET, AGET,
ACFETCH, ACSTORE, AINC, ADEC, A2RS, RS2A, TOSET, TOGET,
@@ -855,7 +859,7 @@ static void (*ops[OPCNT])() = {
static char *opnames[OPCNT] = {
NULL, NULL, NULL, NULL, "bye", "byefail", "quit", "(abort)",
"execute", "(cell)", "(val)", "(alias)", "(does)", "(s)", "(br)", "(?br)",
- "(next)", NULL, NULL, "boot<", "(emit)", "stderr", "key", "drop",
+ "(next)", NULL, "(to)", "boot<", "(emit)", "stderr", "key", "drop",
"dup", "?dup", "swap", "over", "rot", "rot>", "nip", "tuck",
"r>", ">r", "r@", "rdrop", "scnt", "rcnt", ">A", "A>",
"Ac@", "Ac!", "A+", "A-", "A>r", "r>A", "[to]", "to?",
@@ -911,7 +915,9 @@ static void sysalias(char *name, dword addr) {
static void sysval(char *name, dword addr) {
entry(name);
- cwrite(0x12); // SYSVAL
+ callwr(find("(to)"));
+ dwrite(find("@"));
+ dwrite(find("@"));
dwrite(addr);
retwr();
}
