commit 71258be48dfd55ffb6d3eb7f7be111fea092a8af
parent 538a7dc0dd98c63474e74c9a9e5cabcb13b678c2
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Fri, 10 Jun 2022 17:22:42 -0400
Improve "to" semantics
See doc/usage
Diffstat:
5 files changed, 79 insertions(+), 39 deletions(-)
diff --git a/boot.fs b/boot.fs
@@ -9,6 +9,9 @@
: immediate current 1- dup c@ $80 or swap c! ;
: ['] ' litn ; immediate
+: to ['] ! [to] ;
+: to+ ['] +! [to] ;
+: to' ['] noop [to] ;
: compile ' litn ['] call, call, ; immediate
: if compile (?br) here 4 allot ; immediate
: then here swap ! ; immediate
diff --git a/dusk.asm b/dusk.asm
@@ -38,29 +38,29 @@ db %2
%3:
%endmacro
-; If toflag=0, push the value of the dword at addr %1 to PS
-; If toflag!=0 pop PS into the dword at addr %1
+; If toptr=0, push the value of the dword at addr %1 to PS
+; If toptr!=0 jump to that ptr
%macro sysval 1 ; lbl
mov eax,%1
-test byte [toflag], 0xff
+test dword [toptr], -1
jnz to_is_set
mov eax,[eax]
pspush eax
ret
%endmacro
-; If toflag=0, jump to the address pointed at by the dword at addr %1
-; If toflag!=0 pop PS into the dword at addr %1
+; If toptr=0, jump to the address pointed at by the dword at addr %1
+; If toptr!=0 jump to that ptr
%macro sysalias 1 ; lbl
mov eax,%1
-test byte [toflag], 0xff
+test dword [toptr], -1
jnz to_is_set
jmp [eax]
%endmacro
SECTION .bss
areg: resd 1 ; A register
-toflag: resb 1 ; to flag
+toptr: resd 1 ; Current "to" word pointer. 0 means none
exitonabort: resb 1 ; if set, abort will exit(1)
bootptr: resd 1
current: resd 1
@@ -105,7 +105,7 @@ defword 'noop', 4, word_noop
defword 'quit', 4, word_quit
cld
- mov byte [toflag], 0
+ mov dword [toptr], 0
mov dword [inrd], word_iinrd ; make sure input is interactive after a quit
mov esp, rs_top
jmp word_mainloop
@@ -140,19 +140,13 @@ defword '(cell)', 6, word_cellroutine
pspush eax
ret
-to_is_set: ; eax=cell addr
- mov byte [toflag], 0
- pspop ebx
- mov [eax], ebx
- ret
-
; Compiled by "value"
; Called right before a 4b data, RS has its address now.
-; If toflag=0, return that value
-; If toflag=1, pop PS into that address
+; If toptr=0, return that value
+; If toptr!=0 jump to that ptr
defword '(val)', 5, word_valroutine
pop eax
- test byte [toflag], 0xff
+ test dword [toptr], -1
jnz to_is_set
mov ebx, [eax]
pspush ebx
@@ -160,11 +154,11 @@ defword '(val)', 5, word_valroutine
; Compiled by "alias"
; Called right before a 4b word pointer, RS has its address now.
-; If toflag=0, return jump to where it's pointing.
-; If toflag=1, pop PS into that address
+; If toptr=0, return jump to where it's pointing.
+; If toptr!=0 jump to that ptr
defword '(alias)', 7, word_aliasroutine
pop eax
- test byte [toflag], 0xff
+ test dword [toptr], -1
jnz to_is_set
jmp [eax]
@@ -384,15 +378,15 @@ defword 'r>A', 3, word_rs2A
pop dword [areg]
jmp eax
-defword 'to', 2, word_to
- mov byte [toflag], 1
- ret
+to_is_set: ; eax=cell addr
+ pspush eax
+ mov ebx, [toptr]
+ mov dword [toptr], 0
+ jmp ebx
-defword 'to?', 3, word_tocond
- xor eax, eax
- mov al, [toflag]
- pspush eax
- mov byte [toflag], 0
+defword '[to]', 4, word_set_toptr
+ pspop eax
+ mov [toptr], eax
ret
defword '1+', 2, word_inc
@@ -435,6 +429,12 @@ defword '!', 1, word_store
mov [eax], ebx
ret
+defword '+!', 2, word_addstore
+ pspop eax
+ pspop ebx
+ add [eax], ebx
+ ret
+
defword ',', 1, word_write
pspop eax
mov esi, [here]
@@ -849,19 +849,16 @@ defword ';', 0x81, word_compstop
ret
defword 'run1', 4, word_run1
- ; save toflag so that it doesn't mess word/parse/find
- xor eax, eax
- mov al, [toflag]
- push eax
- mov byte [toflag], 0
+ ; save toptr so that it doesn't mess word/parse/find
+ push dword [toptr]
+ mov dword [toptr], 0
call word_word
call word_parse
pspop eax
test eax, eax
jz _run1_notlit
; literal
- pop eax
- mov [toflag], al
+ pop dword [toptr]
ret
_run1_notlit:
call word_curword
@@ -869,8 +866,7 @@ _run1_notlit:
pspop eax
test eax, eax
jz word_wnf
- pop eax
- mov [toflag], al
+ pop dword [toptr]
call word_execute
jmp word_stackcond
diff --git a/fs/doc/usage.txt b/fs/doc/usage.txt
@@ -0,0 +1,32 @@
+# Dusk OS usage
+
+NOTE: this document isn't complete. I'm only writing a few notes that will end
+up being in the usage guide once it's done.
+
+# "to" semantics
+
+Values and aliases are very similar to cells: they're a piece of memory attached
+to a "handling" routine. With the cell, the routine is a noop, it returns the
+address of the piece of memory.
+
+With value and aliases, it's not a noop. The first fetches the value in memory,
+the second jumps to the address contained by that memory.
+
+These routines come with... side effects. How can you modify a value or an
+alias? You need a "to" word.
+
+The "to" words ("to", "to+", "to'") set a global variable with a pointer to an
+alternate routine for value or alias to execute. For example, the "to" word
+makes the "to" global pointer point to "!".
+
+This means that when you do "42 to myvalue", instead of "myvalue" executing the
+equivalent of "addr-of-myvalue @", it executes "addr-of-myvalue !".
+
+Any time a "to" override is used, the "to" pointer is reset to 0.
+
+Warning: this variable is global. any usage of "to" will affect the next value
+or alias that pops up. To avoid problems, always put your "to" call very, very
+close to your value/alias call.
+
+to+ sets "to" to "+!"
+to' sets "to" to "noop" (returns the address)
diff --git a/fs/lib/scratch.fs b/fs/lib/scratch.fs
@@ -14,7 +14,7 @@ scratch( value scratch>
: scratchallot ( n -- a )
scratch> over + scratch) >= if scratch( to scratch> then
- scratch> tuck + to scratch> ( a ) ;
+ to+ scratch> scratch> ( a ) ;
\ push a range to the scratchpad as a string
: []>str ( a u -- str )
dup 1+ scratchallot ( src u dst-1 ) >r dup r@ c!+ swap ( src dst u ) move r> ;
diff --git a/fs/tests/core.fs b/fs/tests/core.fs
@@ -1,10 +1,19 @@
f<< tests/harness.fs
testbegin
-\ Testing lib/core.fs
+\ Testing boot.fs and lib/core.fs
+\ does words
: incer doer , does> @ 1+ ;
41 incer foo
101 incer bar
foo 42 #eq
bar 102 #eq
+
+\ to semantics
+42 value foo
+43 to foo
+foo 43 #eq
+5 to+ foo
+foo 48 #eq
+to' foo @ 48 #eq
testend
