commit 05aa79dd1f7a194a428701b6f1b6b12dadbf17e7
parent dd6f3ffb300d8b2937add9d18d22773d864e0832
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Thu, 9 Jun 2022 06:41:11 -0400
Add does and const words
Diffstat:
11 files changed, 80 insertions(+), 10 deletions(-)
diff --git a/boot.fs b/boot.fs
@@ -6,13 +6,10 @@
: 0< <<c nip ; : 0>= 0< not ;
: >= < not ; : <= > not ;
: -^ swap - ;
-: Ac@+ Ac@ A+ ;
-: Ac!+ Ac! A+ ;
: immediate current 1- dup c@ $80 or swap c! ;
: ['] ' litn ; immediate
: compile ' litn ['] call, call, ; immediate
-: [compile] ' call, ; immediate
: if compile (?br) here 4 allot ; immediate
: then here swap ! ; immediate
: else compile (br) here 4 allot here rot ! ; immediate
@@ -23,7 +20,6 @@
: code word entry ;
: create code compile (cell) ;
: value code compile (val) , ;
-: alias ' code compile (alias) , ;
: \ begin in< $0a = until ; immediate
\ hello, this is a comment!
\ By the way, now that I can talk, it's important to note that
@@ -36,8 +32,6 @@
( hello, another comment! )
: c@+ dup 1+ swap c@ ;
: c!+ tuck c! 1+ ;
-: fill ( a u b -- *A* ) rot> >r >A begin dup Ac!+ next drop ;
-: allot0 ( n -- ) here over 0 fill allot ;
\ transform a fstring into a null-terminated string.
create _ $100 allot
: tocstr ( str -- a ) c@+ >r _ r@ move 0 _ r> + c! _ ;
@@ -49,7 +43,7 @@ create _ 'C' c, 'a' c, 'n' c, ''' c, 't' c, $20 c, 'o' c, 'p' c, 'e' c, 'n' c,
create _ 1 allot
: fread ( fd -- c-or-0 ) 3 ( read ) swap _ 1 lnxcall 1 = if _ c@ else 0 then ;
-create _fds $20 allot0 \ 8 levels max
+create _fds $20 allot \ 8 levels max
_fds value 'curfd
: >fd ( fd -- ) 'curfd 4 + tuck ! to 'curfd ;
: fd@ ( -- fd ) 'curfd @ ;
diff --git a/dusk.asm b/dusk.asm
@@ -131,6 +131,9 @@ defword 'execute', 7, word_execute
pspop eax
jmp eax
+; Compiled by "create"
+; This word is called right before data begins, which means that the address
+; that interests us is right on top of RS.
defword '(cell)', 6, word_cellroutine
pop eax
pspush eax
@@ -142,6 +145,10 @@ to_is_set: ; eax=cell addr
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
defword '(val)', 5, word_valroutine
pop eax
test byte [toflag], 0xff
@@ -150,12 +157,26 @@ defword '(val)', 5, word_valroutine
pspush ebx
ret
+; 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
defword '(alias)', 7, word_aliasroutine
pop eax
test byte [toflag], 0xff
jnz to_is_set
jmp [eax]
+; Compiled by "does"
+; When called, RS points to the address of the word following "does>"
+; After that 4b pointer, data begins, so we want to push its address to PS.
+defword '(does)', 6, word_doesroutine
+ pop eax
+ mov ebx, eax
+ add ebx, 4
+ pspush ebx
+ jmp [eax]
+
; String literal. What follows it is a byte with the length of the string.
; What we do here is to push the address of that string to PS, and then read
; that length byte, then skip that many bytes and jump there.
diff --git a/fs/doc/arch.txt b/fs/doc/arch.txt
@@ -6,6 +6,26 @@ This Forth is a Subroutine Thread Code (STC) Forth, that is, each reference to
words is a native call instead of being a reference. This means that we don't
have a "next" interpret loop. It's calls all the way down.
+# Dictionary structure
+
+Words in this Forth are embedded in a dictionary, which is a list of entries
+each pointing to the previous entry. We keep that last added entry in "current".
+
+The structure of each entry is:
+
+Xb name
+4b link to previous entry
+1b name length + immediate
+--> this is where we link
+
+When we refer to word in Dusk OS, we always refer to its first executable byte,
+right after the name length field. This way, we can call it directly.
+
+"previous entry" field in an entry refers to this same place.
+
+The length field is a 7 bit length with the 8th bit reserved for the "immediate"
+flag (1=immediate).
+
# Caller save
Native words don't save registers they use. For Forth words, it doesn't matter
diff --git a/fs/lib/core.fs b/fs/lib/core.fs
@@ -1,34 +1,53 @@
\ Core forth words that are hard to live without
\ pretty much every Forth source in the system use those words
-$20 value SPC $0d value CR $0a value LF
-$08 value BS $04 value EOF
+\ Compiling words
+: [compile] ' call, ; immediate
+: const code litn exit, ;
+: alias ' code compile (alias) , ;
+: doer code compile (does) 4 allot ;
+
+\ Memory
+: Ac@+ Ac@ A+ ;
+: Ac!+ Ac! A+ ;
+: fill ( a u b -- *A* ) rot> >r >A begin dup Ac!+ next drop ;
+: allot0 ( n -- ) here over 0 fill allot ;
+
+\ Arithmetic
: << <<c drop ;
: >> >>c drop ;
: <> ( n n -- l h ) 2dup > if swap then ;
: min <> drop ; : max <> nip ;
+\ Emitting
\ emit all chars of "str"
+$20 const SPC $0d const CR $0a const LF
+$08 const BS $04 const EOF
+: nl> CR emit LF emit ; : spc> SPC emit ;
: stype ( str -- ) c@+ rtype ;
: ," begin in< dup '"' = if drop exit then c, again ;
: S" compile (s) here 1 allot here ," here -^ ( 'len len ) swap c! ; immediate
: ." [compile] S" compile stype ; immediate
: abort" [compile] ." compile abort ; immediate
+\ Sequences
: [c]? ( c a u -- i )
?dup not if 2drop -1 exit then A>r over >r >r >A ( c )
begin dup Ac@+ = if leave then next ( c )
A- Ac@ = if A> r> - ( i ) else r~ -1 then r>A ;
+\ Number formatting
create _ ," 0123456789abcdef"
: .xh $f and _ + c@ emit ;
: .x1 dup 4 rshift .xh .xh ;
: .x2 dup 8 rshift .x1 .x1 ;
: .x dup 16 rshift .x2 .x2 ;
-: nl> CR emit LF emit ; : spc> SPC emit ;
+
+\ Diagnostic
: psdump scnt not if exit then
scnt >A begin dup .x spc> >r scnt not until
begin r> scnt A> = until ;
: .S ( -- )
S" SP " stype scnt .x1 spc> S" RS " stype rcnt .x1 spc>
S" -- " stype stack? psdump ;
+: does> r> ( exit current definition ) current 5 + ! ;
diff --git a/tests/harness.fs b/tests/harness.fs
@@ -3,3 +3,4 @@ exitonabort
\ # means "assert"
: # ( f -- ) not if abort" assertion failed" then ;
: #eq ( n n -- ) 2dup = if 2drop else swap .x ." != " .x abort then ;
+: #psempty scnt 0 #eq ;
diff --git a/tests/testasm.fs b/tests/testasm.fs
@@ -6,3 +6,4 @@ code foo
ret,
foo 42 #eq
+#psempty
diff --git a/tests/testcc.fs b/tests/testcc.fs
@@ -11,3 +11,5 @@ bwnot $ffffffd5 #eq
exprbinops 7 #eq
boolops 0 #eq
variables 42 #eq
+\ TODO: leak here
+\ #psempty
diff --git a/tests/testccast.fs b/tests/testccast.fs
@@ -13,3 +13,5 @@ firstchild dup astid AST_RETURN #eq ( rnode )
firstchild ( expr ) firstchild ( factor )
firstchild dup astid AST_CONSTANT #eq ( cnode )
data1 42 #eq
+\ TODO: leak here
+\ #psempty
diff --git a/tests/testcctree.fs b/tests/testcctree.fs
@@ -61,3 +61,4 @@ n2 removenode
create expected 1 c, 3 c,
create res n1 traverse
expected res 2 []= #
+#psempty
diff --git a/tests/testcore.fs b/tests/testcore.fs
@@ -0,0 +1,8 @@
+\ Testing lib/core.fs
+: incer doer , does> @ 1+ ;
+41 incer foo
+101 incer bar
+
+foo 42 #eq
+bar 102 #eq
+#psempty
diff --git a/tests/teststr.fs b/tests/teststr.fs
@@ -10,3 +10,4 @@ create list
: _ S" foo" list sfind 1 #eq ; _
: _ S" hello" list sfind 0 #eq ; _
: _ S" baz" list sfind -1 #eq ; _
+#psempty
