commit 5678088c8ecdecfe5a9724292ebf140e26bfc5c8
parent f68551c3cb332536d1558a03cc0a79ac0d8c5978
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Fri, 12 Aug 2022 09:41:45 -0400
Refactor structs again
How they work hasn't changed fundamentally, but how they're defined changed a
lot. It's now possible to add any kind of word in the struct's namespace.
This allows us to differenciate between "methods" and "static functions", which
makes structs lighter. It also makes structs much more versatile, as we'll see
in the upcoming commits.
Diffstat:
6 files changed, 166 insertions(+), 104 deletions(-)
diff --git a/fs/doc/usage.txt b/fs/doc/usage.txt
@@ -89,14 +89,35 @@ Structures are an effective way to address offsets from base addresses while
keeping the general namespace clean. Structures have a name and a list of fields
and are declared thus:
- 3 struct Foo bar baz :bleh
+ struct[ Foo
+ sfield bar
+ sfield baz
+ smethod :bleh
+ ]struct
This describes an 12 byte wide struct with 3 fields. All fields in structs are
always contiguous and 4 bytes wide.
-The name is a string identifying the field. It has no existence in the system
-dictionary and will only be used in the context of that structure, so name
-clashes are not a problem.
+Anything goes inside of a struct. Whatever word you define there will be
+included in the struct's namespace. Those words will not be present in the
+system dictionary. While inside a struct definition, however, you can access
+words inside the struct directly.
+
+"sfield" and "smethod" have a special struct-specific behavior as they
+automatically place themselves inside the struct at the correct offset and
+increase the struct's size.
+
+A struct size can be obtained with "structsz". It returns the size, in bytes, of
+the fields included in the struct. It can also be used inside a struct
+definition to get the struct size "up until now". This can be useful for buffers
+inside structs:
+
+ struct[ Foo
+ sfield bar
+ sfield baz
+ smethod :bleh
+ ' Foo structsz &+ buf( \ yields the address at the end of the fields
+ ]struct
A struct hold no data by itself and can't be used directly to access fields from
memory. You refer to fields in a struct by supplying it with a source pointer,
@@ -117,12 +138,13 @@ Field access can be compiled:
: foobar data2 Foo baz ;
foobar . \ prints 4
-A field name starting with : is a "method". This means that it behaves like an
-alias instead of like a value. The ":" stays in the name, you have to include it
-when you invoke the method. When the method is invoked, a copy of the data
-pointer is pushed to PS. For example, if you had:
+A method is an alias to a word reference inside a struct. When the method is
+invoked, it dereferences the alias and calls it, but it also pushes a reference
+of the data structure on top of PS so that the method can work with its data.
+By convention, method names start with ":", but nothing forces you to have it.
+Example of a method that add bar and baz:
- : mybleh dup Foo bar swap Foo baz + ;
+ : mybleh ( 'data -- n ) dup Foo bar swap Foo baz + ;
defined before the previous examples, then you could do:
@@ -137,7 +159,13 @@ You will often want to bind data to structs. You can do so with "structbind":
You can also extend a previous struct with a new struct:
- extends Foo 1 struct Bar bazooka
+ extends Foo struct[ Bar
+ sfield bazooka
+ ]struct
create data3 1 , 2 , ' mybleh , 1234
data3 Bar bazooka . \ prints 1234
data3 Bar bar . \ prints 1
+
+Extended structs will have their "running size" pick up where the extended
+struct left. They will also inherit their whole namespace, but only upon closing
+the struct's definition.
diff --git a/fs/fs/fat.fs b/fs/fs/fat.fs
@@ -108,7 +108,7 @@ $ffff const EOC
>r begin ( cluster ) FAT@+ next then ( cluster ) drop ;
: fatwritebuf ( buf n fcursor -- n )
- dup FATCursorFree? if 2drop drop 0 exit then ( buf n fcursor )
+ dup FATFile :free? if 2drop drop 0 exit then ( buf n fcursor )
dup >r FATFile pos over + r@ fatgrow ( src n )
r@ FATFile pos r@ fatseek
r@ FCUR_flags 2 or ( dirty ) r@ to FATFile flags
diff --git a/fs/fs/fatlo.fs b/fs/fs/fatlo.fs
@@ -37,13 +37,15 @@ create fatbuf( FATMAXSECSZ 1+ allot
: readsector ( sec cnt -- )
to bufseccnt dup to bufsec fatbuf( fatdrv Drive :sec@ ;
-extends Filesystem 7 struct FATFields
- secsz secpercluster reservedseccnt FATcnt rootentcnt seccnt FATsz
-\ secsz in bytes
-\ reservedseccnt number of sectors reserved before FAT starts
-\ FATcnt >1 means backup FATs
-\ rootentcnt count of 32b entries
-\ FATsz in bytes
+extends Filesystem struct[ FATFields
+ sfield secsz \ in bytes
+ sfield secpercluster
+ sfield reservedseccnt \ number of sectors reserved before FAT starts
+ sfield FATcnt \ >1 means backup FATs
+ sfield rootentcnt \ count of 32b entries
+ sfield seccnt
+ sfield FATsz \ in bytes
+]struct
\ TODO: support more than one FAT FS at once
create _FATFS
@@ -167,28 +169,29 @@ here const )fnbuf
current _FATFS 4 + !
\ File cursor
-\ flags: all zeroes = free cursor
-\ b0 = used
-\ b1 = buffer is dirty
-\ cluster: current cluster in buf 0=nothing. the cluster is not actually read
-\ until the first position of the cluster is needed.
-\ clusteridx: current cluster index, -1=nothing.
-\ pos: offset from beginning of file
-\ size: file size
-\ buf(: beginning of a buffer with the size ClusterSize
-extends File 12 struct FATFile
- flags cluster clusteridx pos size entryoff
- :buf( :)buf :dirty? :bufpos :dirent :cluster0
+extends File struct[ FATFile
+ \ all zeroes = free cursor
+ \ b0 = used
+ \ b1 = buffer is dirty
+ sfield flags
+ \ current cluster in buf 0=nothing. the cluster is not actually read
+ \ until the first position of the cluster is needed.
+ sfield cluster
+ sfield clusteridx \ current cluster index, -1=nothing.
+ sfield pos \ offset from beginning of file
+ sfield size
+ sfield entryoff
+ \ beginning of a buffer with the size ClusterSize
+ ' FATFile structsz &+ :buf(
+ : :)buf ( self -- a ) :buf( ClusterSize + ;
+ : :free? ( self -- f ) flags not ;
+ : :dirty? ( self -- f ) flags 2 and ;
+ : :bufpos ( self -- a ) dup pos ClusterSize mod swap :buf( + ;
+ : :dirent ( self -- dirent ) entryoff getdirentry ;
+ : :cluster0 ( self -- cl ) :dirent DIR_Cluster ;
+]struct
' FATFile structsz const FATFILESZ
: FCursorSize ClusterSize FATFILESZ + ;
-10 const FCURSORCNT \ maximum number of opened files
-: _:buf( ( self -- a ) FATFILESZ + ;
-: _:)buf ( self -- a ) _:buf( ClusterSize + ;
-: _:dirty? ( self -- f ) FATFile flags 2 and ;
-: _:bufpos ( self -- a ) dup FATFile pos ClusterSize mod swap _:buf( + ;
-: _:dirent ( self -- dirent ) FATFile entryoff getdirentry ;
-: _:cluster0 ( self -- cl ) _:dirent DIR_Cluster ;
-: FATCursorFree? ( hdl -- f ) FATFile flags not ;
\ FAT cursors are kept in the form of a linked list. The "next" field is outside
\ of the FATFile structure
@@ -200,7 +203,7 @@ extends File 12 struct FATFile
: findfreecursor ( -- hdl )
lastcursor begin ( ll )
- ?dup while dup CELLSZ + FATCursorFree? if CELLSZ + exit then
+ ?dup while dup CELLSZ + FATFile :free? if CELLSZ + exit then
llnext repeat
\ no existing free cursor, create a new one
createcursor ;
@@ -218,24 +221,24 @@ extends File 12 struct FATFile
\ set fcursor to pos. If new pos crosses cluster boundaries compared to current
\ pos, flush current buffer and read a new sector from disk.
: fatseek ( pos fcursor -- )
- dup FATCursorFree? if 2drop exit then ( pos fcursor )
+ dup FATFile :free? if 2drop exit then ( pos fcursor )
over 0< if abort" can't seek to negative pos" then
over ClusterSize / over FATFile clusteridx = not if
dup IO :flush >r ( pos )
dup ClusterSize / dup r@ to FATFile clusteridx ( pos idx )
- r@ _:cluster0 ( pos idx cl )
+ r@ FATFile :cluster0 ( pos idx cl )
swap ?dup if >r begin ( pos cl ) FAT@ next then ( pos cl )
dup r@ FATFile :buf( readcluster ( pos cl )
r@ to FATFile cluster r> ( pos fc )
then ( pos fcursor ) to FATFile pos ;
: fatreadbuf ( n fcursor -- a? n )
- dup FATCursorFree? if 2drop 0 exit then ( n fcursor )
+ dup FATFile :free? if 2drop 0 exit then ( n fcursor )
dup >r FATFile size r@ FATFile pos - ( n maxn )
dup 1- 0< if ( EOF ) 2drop rdrop 0 exit then
min ( n ) \ make sure that n doesn't go over size
r@ FATFile pos r@ fatseek ( n )
- r@ _:bufpos r@ _:)buf over - ( n a nmax )
+ r@ FATFile :bufpos r@ FATFile :)buf over - ( n a nmax )
rot min ( a n )
dup r> to+ FATFile pos ( a n ) ;
@@ -249,8 +252,6 @@ create _EmptyCursor
\ FAT fields
1 ( flags ) , 0 ( cluster ) , -1 ( clusteridx ) , 0 ( pos ) ,
0 ( size ) , 0 ( entryoff ) ,
- \ FAT methods
- ' _:buf( , ' _:)buf , ' _:dirty? , ' _:bufpos , ' _:dirent , ' _:cluster0 ,
\ This is the "low" part. Complete open is finalized in fs/fat
: FATFS:open ( id self -- hdl )
diff --git a/fs/lib/scratch.fs b/fs/lib/scratch.fs
@@ -9,29 +9,31 @@
\ The system scratchpad lives at sys/scratch.
-8 struct Scratchpad
- size ptr :buf( :)buf :allot :[]>str :[ :]
-
-: _buf( ( self -- a ) ['] Scratchpad structsz + ;
-: _buf) ( self -- a ) dup _buf( swap Scratchpad size + ;
-: _allot ( n self -- a )
- dup >r Scratchpad ptr over + r@ _buf) >= if
- ." scratch reload!" nl> r@ _buf( to r@ Scratchpad ptr then
- r@ Scratchpad ptr swap to+ r> Scratchpad ptr ( a ) ;
-\ push a range to the scratchpad as a string
-: _[]>str ( a u self -- str )
- over 1+ swap _allot ( src u dst-1 )
- >r dup r@ c!+ swap ( src dst u ) move r> ;
-
-0 value _here
-
-\ Open a scratch area for writing
-: _[ ( self -- ) here to _here Scratchpad ptr to here ;
-\ Stop writing to the scratch area and restore here
-\ Returns the address of the beginning of the written area
-: _] ( self -- a ) here swap to@! Scratchpad ptr _here to here ;
+struct[ Scratchpad
+ sfield size
+ sfield ptr
+
+ ' Scratchpad structsz &+ :buf(
+ : :)buf ( self -- a ) dup :buf( swap size + ;
+ : :allot ( n self -- a )
+ dup >r ptr over + r@ :)buf >= if
+ ." scratch reload!" nl> r@ :buf( to r@ ptr then
+ r@ ptr swap to+ r> ptr ( a ) ;
+
+ \ push a range to the scratchpad as a string
+ : :[]>str ( a u self -- str )
+ over 1+ swap :allot ( src u dst-1 )
+ >r dup r@ c!+ swap ( src dst u ) move r> ;
+
+ 0 value _here
+ \ Open a scratch area for writing
+ : :[ ( self -- ) here to _here ptr to here ;
+ \ Stop writing to the scratch area and restore here
+ \ Returns the address of the beginning of the written area
+ : :] ( self -- a ) here swap to@! ptr _here to here ;
+
+]struct
: scratchpad$ ( size -- )
- here over , _buf( ,
- ['] _buf( , ['] _buf , ['] _allot , ['] _[]>str , ['] _[ , ['] _] , allot ;
+ here over , Scratchpad :buf( , allot ;
diff --git a/fs/tests/kernel.fs b/fs/tests/kernel.fs
@@ -86,6 +86,7 @@ to' ll llinsert drop 33 ,
ll myfield 33 #eq
ll llnext myfield 42 #eq
ll llnext llnext myfield 54 #eq
+ll llnext llnext ll llprev myfield 42 #eq
ll llcnt 3 #eq
\ metadata
@@ -101,13 +102,18 @@ floaded #
S" /tests/harness.fs" findpath floaded? #
\ Structures
-
-3 struct Foo bar baz :bleh
-: mybleh dup Foo bar swap Foo baz + ;
+struct[ Foo
+ sfield bar
+ sfield baz
+ smethod :bleh
+]struct
+\ ' Foo structsize 12 #eq
+: mybleh ( 'data -- n ) dup Foo bar swap Foo baz + ;
create data1 1 , 2 , ' mybleh ,
create data2 3 , 4 , ' mybleh ,
data1 Foo bar 1 #eq
data2 Foo baz 4 #eq
+data1 Foo :bleh 3 #eq
42 to+ data1 Foo baz
data1 Foo baz 44 #eq
: myword data2 Foo bar ;
@@ -124,7 +130,9 @@ myword 45 #eq
data1 Foo :bleh 46 #eq
myword 46 #eq
-extends Foo 1 struct Bazooka bling
+extends Foo struct[ Bazooka
+ sfield bling
+]struct
create data3 7 , 9 , ' mybleh , 999 ,
data3 Bazooka bling 999 #eq
data3 Bazooka baz 9 #eq
diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs
@@ -85,8 +85,6 @@
: &c@ ( n -- ) doer , does> @ c@ ;
: &+@ ( n -- ) doer , does> @ + @ ;
: &+! ( n -- ) doer , does> @ + ! ;
-: _ @ + ;
-: field ( off -- ) code compile (to) ['] _ , ['] @ , , exit, ;
\ while..repeat
: while [compile] if swap ; immediate
@@ -108,13 +106,6 @@ alias else endof immediate
: endcase ( then-stopgap jump1? jump2? ... jumpn? -- )
?dup if begin [compile] then ?dup not until then compile rdrop ; immediate
-\ Linked lists. See doc/usage.
-: llnext @ ;
-: llend ( ll -- lastll ) begin dup @ ?dup while nip repeat ( ll ) ;
-: lladd ( ll -- newll ) here swap llend ! here 0 , ;
-: llinsert ( 'll -- newll ) here over @ , ( 'll newll ) dup rot ! ;
-: llcnt ( ll -- count ) A>r 0 >A begin ?dup while A+ llnext repeat A> r>A ;
-
\ Emitting
$20 const SPC $0d const CR $0a const LF $08 const BS
: nl> CR emit LF emit ; : spc> SPC emit ;
@@ -133,6 +124,16 @@ $20 const SPC $0d const CR $0a const LF $08 const BS
: [if] not if S" [then]" begin word over s= until drop then ;
alias noop [then]
+\ Linked lists. See doc/usage.
+: llnext @ ;
+: llend ( ll -- lastll ) begin dup llnext ?dup while nip repeat ( ll ) ;
+: llprev ( tgt ll -- prev )
+ begin 2dup llnext = not while llnext ?dup while repeat
+ abort" llprev failed" then nip ;
+: lladd ( ll -- newll ) here swap llend ! here 0 , ;
+: llinsert ( 'll -- newll ) here over @ , ( 'll newll ) dup rot ! ;
+: llcnt ( ll -- count ) A>r 0 >A begin ?dup while A+ llnext repeat A> r>A ;
+
\ Dictionary
-5 &+@ preventry
-9 &+@ emeta
@@ -169,27 +170,33 @@ alias noop [then]
\ Structures
-: _val' ( 'data 'off -- a ) @ + ;
-: _method over + @ execute ;
0 value _extends
: extends ' to _extends ;
-: 'structsz ( 'struct -- sz ) @ llcnt CELLSZ * ;
-: structsz ( struct -- sz ) does' 'structsz ;
-
-\ 4b link to dict
-: struct ( cnt -- )
- doer immediate >r here 0 to@! _extends dup if does' @ then ,
- dup 'structsz begin ( 'dict off )
- over word entry ( 'dict off )
- curword 1+ c@ ':' = if
- dup litn compile _method else
- compile (to) ['] _val' , ['] @ , dup , then ( 'dict off )
- exit, CELLSZ + next ( 'dict off ) 2drop
- does> ( 'data? 'struct -- *to* ) \ when imm, 'data? is absent
- @ ( 'data? 'fielddict )
- word swap ( 'data? str 'dict ) find ( 'data? 'field )
- ?dup not if curword stype abort" field doesn't exist!" then
- compiling if ( 'field ) execute, else execute then ;
+0 value _cur
+: _structsz' ( struct -- a ) does' CELLSZ + ;
+: _struct+ ( struct ) CELLSZ swap _structsz' +! ;
+: structsz ( struct -- sz ) _structsz' @ ;
+
+\ 4b dict
+\ 4b data size
+: struct[
+ doer 0 , _extends dup if _structsz' @ then ,
+ sysdict @ to _cur immediate
+does> ( 'struct )
+ @ ( 'dict ) word swap ( str 'dict ) find ( 'word )
+ ?dup not if curword stype abort" not in namespace!" then
+ compiling if execute, else execute then ;
+: ]struct
+ \ break the chain at the first field of the struct
+ 0 to@! _extends dup if does' @ then _cur sysdict llprev !
+ \ Rewind the sysdict to our struct
+ _cur sysdict @! _cur e>w does' ! ;
+
+: _val' ( 'data 'off -- a ) @ + ;
+: field ( off -- ) code compile (to) ['] _val' , ['] @ , , exit, ;
+: method ( off -- ) doer , does> @ over + @ execute ;
+: sfield _cur e>w structsz field _cur e>w _struct+ ;
+: smethod _cur e>w structsz method _cur e>w _struct+ ;
\ 4b link to struct
\ 4b link to data
@@ -199,17 +206,33 @@ alias noop [then]
\ Drive API
\ Anticipating lib/drive
-3 struct Drive secsz :sec@ :sec!
+struct[ Drive
+ sfield secsz
+ smethod :sec@
+ smethod :sec!
+]struct
\ I/O API
\ Anticipating lib/io
-3 struct IO :readbuf :writebuf :flush
+struct[ IO
+ smethod :readbuf
+ smethod :writebuf
+ smethod :flush
+]struct
\ File API
\ Anticipating lib/file
-4 struct Filesystem :drv :child :open :newfile
+struct[ Filesystem
+ sfield drv
+ smethod :child
+ smethod :open
+ smethod :newfile
+]struct
alias abort activefs immediate
-extends IO 2 struct File :seek :close
+extends IO struct[ File
+ smethod :seek
+ smethod :close
+]struct
\ Autoloading
0 value floaded \ address of the current "loaded file" structure
